%begin ! ! !********************************************************************* ! ! MORE COMMENTS AND SWITCH SYSFUN(232) - SYSFUN(280) TIDIED UP ! !********************************************************************* ! ! CHANNEL USAGE ! ST01 - T#DUMP ! ST02 - LOGNAM ! ST03 - T#TEMP ! SM04 - LOGOFILE ! SM06 - T#LOGOSTK ! SM07 - LOGOMON ! SM08 - BFILE ! SM10 - JUNK FILE ! !***************************************** ! GRAPHICS LINKAGE !***************************************** ! %external %integer %fn %spec conv(%integer x) %external %routine %spec vecorpoint(%integer i, j, k, l) %external %routine %spec pause %external %routine %spec load42(%string (63) file) %external %routine %spec set42(%integer nm) %external %routine %spec clear42 %external %routine %spec ch3(%integer char) %external %routine %spec mode42(%integer n) %external %routine %spec lbr %external %routine %spec rbr ! PARENTHESIS %const %integer initgraphp = X'202E' ! START OF DISPLAY SPACE ! %extrinsic %integer graphp42 %extrinsic %integer cur42mode %extrinsic %integer ddata, dstart, dlast, graphp !POINTERS TO GT42 CORE %extrinsic %integer vectorm, pointm, charm !EMAS GT42 EXEC INSTRUCTIONS %extrinsic %integer bleep, chtxt, chpic, gradv, add2, set, add1, setn, wait, pmov, clr, ack !GT42EXECINSTRUCTIONS ! %own %integer pen = X'4000', normal = X'9E54', djump = X'E000', frametime = 50 %const %integer corebottom = X'3FF0' %const %integer call = 0, posnat = X'C000', lineto = X'8000' %integer textflag, gmode, curpic, curmovie, curframe, defpicture, %C curmode, frameflag, grablist, picturepointer %const %integer turtlestart = X'201A' %const %string (17) gt42exec = "ECMI05.EXEC26" %own %integer showturtle42 = 1 ! ! MOVIE AREA ! %record %format picdir(%C %integer ptr, ptr42, x, y, faddr, moved, mode, lastmovetime) %own %record (picdir) %array index42(0 : 1022) %string (10) savepromp %own %integer capflag = 0 ! USED TO GENERATE CAPTIONS ! ! ! %integer xcrane, ycrane, hdcrane %const %integer cranemark = X'000F0000', cranemask = X'FFFF0000' !*************************************************** %external %routine %spec dresume(%integer lnb, pc, addr18) %external %routine %spec reroutecontingency(%integer ep, class, %long %integer mask, %routine %name rr, %integer %name flag) %external %integer %fn %spec readid(%integer adr) %external %routine %spec edinner(%integer st, sl, sc1, sc2, awsp, %C %integer %name l) %external %routine %spec disconnect(%string (63) s) %external %routine %spec closesm(%integer ch) %external %string %fn %spec uinfs(%integer type) %record %format f(%C %integer ad, type, dst, dend, size, rup, eep, mode, cons, arch, %C %string (6) trans, %string (8) date, time, %C %integer count, spare1, spare2) %external %routine %spec finfo(%string (15) s, %integer lev, %C %record (f) %name r, %integer %name flag) %external %routine %spec fill(%integer len, addr, val) %external %routine %spec move(%integer length, from, to) %external %string %fn %spec date %external %routine %spec list(%string (63) s) %external %string %fn %spec time %external %long %real %fn %spec cputime %external %integer %fn %spec smaddr(%integer chann, %integer %name length) %external %routine %spec define(%string (65) s) %external %routine %spec permit(%string (65) s) %external %routine %spec newsmfile(%string (63) s) %external %routine %spec cherish(%string (63) s) %external %routine %spec prompt(%string (15) m) %external %routine %spec destroy(%string (65) s) %external %routine %spec closestream(%integer ch) %external %real %fn %spec random(%integer %name i, %integer j) %external %string %fn %spec interrupt %external %routine %spec rename(%string (65) s) %external %routine %spec clear(%string (65) s) %record %format rf(%integer conad, type, start, end) %external %routine %spec connect(%string (31) file, %C %integer mode, hole, prot, %record (rf) %name r, %integer %name flag) %routine %spec baderror(%string (80) errmess, %integer culprit) %routine %spec applyusr(%integer envir, fun, tstflg, val, %C %integer %name severity) %routine %spec nooline(%integer n) %routine %spec prstring(%string (255) word) %integer %fn %spec unstack %integer %fn %spec checkstack %routine %spec printlist(%integer list) %routine %spec printel(%integer i) %integer %fn %spec hd(%integer list) %integer %fn %spec tl(%integer list) %routine %spec printline(%integer line) %integer %fn %spec readline %routine %spec logo(%integer stktop, envir, severity) %routine %spec dump(%string (80) errmess) %routine %spec getpage(%integer flag) %integer flength, fstart ! FOR FILE MAPPING %string (6) emasuser ! AS A STRING %const %integer maxsource = 50000 ! ! ! ! THE FOLLOWING DECLARATIONS ARE CONCERNED WITH TRAPPING TIME EXCEEDED ! AND RESETTING THE LOCAL TIME LIMIT, AND DEALING WITH CONSOLE INTS ! %EXTERNALROUTINESPEC GETTIM(%INTEGERNAME I) %external %routine %spec signal(%integer ep, parm, extra, %C %integer %name flag) !@#$ %EXTERNALROUTINESPEC SVC(%RECORDNAME P) !@#$ %RECORDFORMAT PARM(%SHORTINTEGER DEST,DUM1,%C !@#$ %INTEGER DUM2, !@#$ DUM3,ARG1,ARG2,ARG3,ARG4) !@#$ %RECORD P(PARM) !%STRINGNAME INTCHAR !%OWNINTEGERARRAY SAVE(1:26) !%OWNINTEGERARRAY RR(4:15) %own %integer i, k, flag, adump, r3 ! ! ! ! WORD AREA AND NUMBER DECLARATIONS ! %byte %integer %array inbuff(0 : 500) %integer inptr, headin, unusedhd %string %array %name wa %string (64) %array %format sform1(0 : 1022) ! WORD TABLE %own %integer wm = 1, nm = 4 ! WORD MARKER,NUMBER MARKER %own %integer t8 = X'FF000000' %integer numtop, numbot ! NUMBER RANGE DELIMITERS %own %integer maxint = X'7FFFFFFF' ! MAXIMUM INTEGER ALLOWED BY IMP %own %integer ranseed = 50003 %string (64) %name work1 %integer logotime %integer %array intstr(1 : 20) %string (4) space4 %integer %name hashval, lbrak, rbrak, dots, empty, undef, and, repeat, %C apply, do, comma, quote, lpar, rpar, minus, if, then, else, close, %C while, unminus, ift, iff, true, false, end, delete, undo, undos, to, %C err, logoname, def, langbrks, rangbrks, quit, break, space1, %C tab, enel, start, finish, comment %integer %array names(1 : 100) ! CONTAINS HASHED VALUES OF ! SPECHARS AND RESERVED NAMES %own %integer %array spechar(1 : 14) = ':', '<', '>', '''', '(', ')', %C '*', '+', ',', '-', '/', '=', '[', ']' %integer prnum %string (4) promp %integer evalimit, evalcnt, parselimit, parsecnt ! ! FUNCTION SPEC INFO IS HELD IN ARRAY FNVAL WHICH IS ! PARALLEL TO WA AND IS ACCESSED DIRECTLY USING ! WORD INDEX. ! EACH ENTRY IN FNVAL WILL BE ONE OF THE FOLLOWING.... ! ! FNVAL ENTRY ! FUNCTION TYPE B4 B3 B2 B1 ! 1) SYSTEM PREFIX TRACEFLAG/1 ARGNO SWITCH......... ! 2) SYSTEM INFIX TRACEFLAG/2 PREC. SWITCH........ ! 3) SYSTEM INTERP 4 - SWITCH - ! 4) USER PREFIX TRACEFLAG/8 LA(INDEX) ARGNO ! 5) UNDEFINED 0 0 0 0 ! ! FNTEXT HOLDS POINTERS TO START OF TEXT OF FN ! FNLEN HOLDS THE LENGTH OF THE FN TEXT (IN BYTES) ! ! ! FUNCTION SPEC AREA DECLARATIONS ! %byte %integer %array %format parseform(0 : 1022) %byte %integer %array %name fnparse %integer %array %name fnval, oldfn, assocwa, fntext, fnlen %integer %array %format 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 %own %integer syspre = X'1000000', infix = X'2000000', %C interp = X'4000000', userpre = X'8000000' %own %integer b3b = X'7F0000', b2 = X'FFFF', b4 = X'3F000000', %C m16 = X'FFFF00' %own %integer traceflg = X'C0000000', unmask = X'3FFFFFFF' %own %integer trace1 = X'40000000', trace2 = X'80000000' %own %integer restart = 0 ! SET BY BADERROR FOR REINIT %integer indent ! ! ! ! USER STACK DECLARATIONS ! %integer %array %name stk %integer stktop, stkpnt ! ! ! SYSTEM STACK DECLARATONS ! %integer %array %name systk %integer %array %format intform2(1 : 2000) %integer systkpnt ! ! ! ! LIST AREA DECLARATIONS ! %integer %array %name la %integer %array %format 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. %byte %integer %array %name source %byte %integer %array %format sourceform(0 : 50000) %integer linenumlist %integer level, fndefn, sourceptr, parlevel, condflag, diagflag, plevel, %C goflag %own %integer la1b = 1, la1t = 24576, la2b = 24577, la2t = 49152, %C lafnb = 49153, 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 %integer %name nil %string (1) sep ! USED BY PRINTER %own %string (1) stermin = " " ! NL AS STRING %own %integer termin = 10 ! NL AS SYMBOL %integer charout %integer enuf %own %integer lm = 2 ! ! ! ! ENVIRONMENT DECLARATIONS ! %integer %array %name bname, bvalue %integer %array %format intform4(1023 : 3000) %integer %array %format intform5(0 : 3000) %integer basenvir, topmark ! ! ! ! INFERENCE SYSTEM DECLARATIONS ! %integer %name factkeys, infkeys, impkeys, fact, implies, toinfer %integer %name 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 %integer %name thinkaloud, new, vbl, not ! THINKALOUD IS A LOGO VARIABLE SET TO TRUE OR FALSE BY THE USER %integer genos %integer %array 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 USERFUN IN THE ! CURRENT NEST. SENDFLAG IS SET BY SENDBACK IN APPLYSYS. ! ! %integer jumpflag, jumpout, sendflag, libload, superjmp %integer quitflag, holdflag ! USER INT FLAGS ! %integer %name quitotop ! LOGO VARIABLE, SET TO TRUE OR FALSE BY THE USER ! DETERMINES WHETHER OR NOT TO ENTER THE PRIMEVAL FUNCTION RECUSIVELY, ! AFTER THE OCCURENCE OF AN ERROR ! DEFAULT IS TRUE - RETURN TO TOP LEVEL ! ! ! ! WORD AREA ! ! WORDS (EXCLUDING NUMBERS) ARE HELD UNIQUELY IN STRING ARRAY WA ! AND ARE REPRESENTED BY AN INTEGER CARRYING THE WORD MARKER AND THE ! INDEX IN WA. ! NUMBERS ARE REPRESENTED BY AN INTEGER CARRYING THE ! BINARY VALUE OF THE NUMBER IN THE TOP THREE BYTES AND THE ! NUMBER MARKER IN THE BOTTOM BYTE. ! FUNCTION PUT IS USED TO TRANSFORM WORDS INCLUDING NUMBERS ! TO INTERNAL FORM. IF THE WORD IS A NUMBER IT IS CONVERTED TO ! BINARY OTHERWISE IT IS HASHED. ! FUNCTION HASH PLACES A WORD INTO WA. AN OPEN HASH IS USED STARTING ! WITH A KEY GENERATD BY FUNCTION HASHFUN. THE KEY IS INCREMENTED ! WHEN NECESSARY BY 1, IN ORDER TO KEEP THE SEARCH AREA TO A PAGE ! OR SO. ! ! ! ! FILING SYSTEM VARIABLES ! %own %integer tty = 0, disc = 1, srce = 2 %integer device, index, newfn, cactfile, flen, filstart, tstart, sindex %integer mdp, mdind, udp, txtp %string (64) userfile %string (20) maswrite, masread, masfile %const %string (7) masnum = "ECMI05." %own %string (8) %array sysfiles(1 : 2) = "LOGALERT", "EXEC26" %string (6) owner %byte %integer %name mdents, tmdents, udents, tudents %byte %integer %name mdnext, tmdnext, udnext, tudnext %byte %integer %name txtnext, ttxtnext, endtxt, tendtxt %byte %integer %array %name txtents, ttxtents, endind, tendind %string %array %name udnam, tudnam, funnam, tfunnam %byte %integer %array %name txtind, ttxtind %byte %integer %array %name fntxt, tfntxt, udpage, tudpage, txtpage, ttxtpage %string (64) %array %format df(1 : 62) %string (64) %array %format ff(1 : 60) %byte %integer %array %format xf(1 : 60) %byte %integer %array %format pf(1 : 62) %byte %integer %array %format sf(1 : 2) %byte %integer %array %format nf(1 : 2, 1:60) %byte %integer %array %format tf(0 : 4092) ! ! ! ! SPECIAL OUTPUT DEVICE VARS ! %integer tdev ! DEVICE NUMBER ALLOCATED ELSE 0 %own %string (10) %C %array tdevnames(1 : 8) = "PLOTTERA", "PLOTTERB", "DISPLAY", "TURTLE", %C "TAPE", "MUSIC", "MECCANO", "GT42" %real xturtle, yturtle %integer hdturtle, penturtle ! TURTLE STATE %own %integer hootbit = X'8080', penbit = X'4000', fdbits = X'2800', %C bdbits = X'1800', rtbits = X'3800', ltbits = X'800', %C pindlbit = X'1000', pindrbit = X'4000' %integer %name up, down ! UP DOWN AS LOGO WORDS TO SET PENTURTLE %byte %integer %array binbuff(0 : 13) ! BUFFER FOR BINARY OUTPUT %integer addrbinbuff ! ADDRESS PF BINBUFF(1) ! ! PARSE DECLARATIONS ! %const %integer qu = X'10', dts = X'20', fnm = X'40', lp = X'80', %C markermask = X'FFFFFF0F', intr = -1, fault = -2 ! ! ! CODE INSERTED TO MONITOR HASHFN ! LOGO COMMAND HASHINFO ! %integer %array 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 ! %integer %fn hash(%string (64) word) %integer wpoint, fullmark, hash %string (64) w ! %integer %fn 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 = "?" %then %start ! 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 %then %start hash1024 = hash1024 + 1 %result = wpoint << 8 ! wm ! ALREADY ENTERED %finish wpoint = wpoint + 1 ! NOT AT KEY POSITION SO INCREMENT %if wpoint > 1022 %then %start ! TAKE MODULO AND CHECK FOR WA FUL %if fullmark = 1 %then baderror("WORD AREA OVERFLOW", empty) %else %C %start fullmark = 1 wpoint = 0 %finish %finish -> lp %end ! END HASH ! %integer %fn 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 %byte %integer %array 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 = "" %then %result = hash(word) %while i > 0 %cycle char = strbyte(i) %if 47 < char < 58 %then %start %if toolong = 1 %then %start i = i - 1 num = numtop + 1 %finish %else %start num = num + (char - 48) * j j = j * 10 i = i - 1 %finish %finish %else %result = hash(word) %repeat %if num > numtop %then %start prstring("NUMBER OUTSIDE RANGE.") space prstring("MAX. SUBSTITUTED") nooline(1) num = numtop %finish %result = num << 8 ! nm %end ! END PUT ! ! ! ! SERVICE ROUTINES ! %string (64) %fn numtostr(%integer num) ! NUM WILL ALWAYS BE POSITIVE NUMBER IN STANDARD FORM AND IN ! RANGE. IT IS CONVERTED TO A STRING BUT IS NOT HASHED SICE ! THIS CONVERSION WILL ONLY BE CARRIED OUT BY CHAR FUNS PRIOR ! TO A CHAR MANIPULATION WHOSE RESULT WILL BE HASHED %own %integer %array tens(1 : 7) = %C 1000000, 100000, 10000, 1000, 100, 10, 1 %integer i, j, k, l, wind, mark %byte %integer %array 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 %then %start word(wind) = l + 48 wind = wind + 1 %finish %repeat %if wind = 1 %then %start ! NUMBER WAS ZERO word(wind) = 48 wind = 2 %finish word(0) = wind - 1 %result = string(addr(word(0))) %end ! END NUMTOSTR ! %routine cluserfl !DISCONNECTS CURRENT FILE closesm(4) clear("4") disconnect(masfile) %end ! END CLUSERFL ! %routine getmaster ! CONNECTS MASTER FILE define("4,LOGOFILE") filstart = smaddr(4, flen) %end ! END GETMASTER ! %routine freemaster ! DISCONNECTS MASTER FILE IN WRITE AND RECONNECTS IN READ closesm(4) permit(masread) %unless cactfile = 2 %then getmaster %end ! END FREEMASTER ! %integer %fn status(%string (15) filename, %integer level) ! FINDS CONNECT STATUS OF FILENAME %record (f) r %integer flag, res finfo("NOFILE", 0, r, flag) finfo(filename, level, r, flag) %if flag > 0 %then %result = -flag res = r_mode %if r_cons = 0 %then %result = 0 %result = res %end ! END STATUS ! ! %routine %spec printfnline(%integer %name sptr) %routine baderror(%string (80) errmess, %integer culprit) %integer funlist, fun, ptr %real fail17 %if tdev = 8 %then set42(chtxt) nooline(1) prstring(errmess) space printel(culprit) nooline(1) dump(errmess) restart = 1 ! FOR REINIT prstring("SAVING NEW FUNCTIONS IN TEMPORARY FILE") nooline(1) define("3,T#TEMP") selectoutput(3) device = tty funlist = newfn %while funlist # nil %cycle ptr = fntext(hd(funlist) >> 8) %until source(fun) = 'E' %and source(fun + 1) = 'N' %C %and source(fun + 2) = 'D' %cycle fun = ptr printfnline(ptr) %repeat funlist = tl(funlist) %repeat prstring("GETTY") nooline(1) selectoutput(0) prstring("SAVED") nooline(1) closestream(3) cluserfl closesm(6) clear("6") destroy("T#LOGOSTK") fail17 = 1.0 / 0 ! FAILS FAULT17 %end ! END BADERROR ! %integer %fn time100 %long %real x x = cputime %result = int(cputime * 100) %end ! END TIME100 ! ! ! ! FILING SYSTEM MAPPING ROUTINES ! %routine mdmap(%integer mdstart) ! MAPS A PAGE IN MASTER DIRECTOR FORMAT mdents == byteinteger(mdstart + 1) mdnext == byteinteger(mdstart + 3) udnam == array(mdstart + 4, df) udpage == array(mdstart + 4034, pf) %end ! END MDMAP ! %routine tmdmap(%integer start) tmdents == byteinteger(start + 1) tmdnext == byteinteger(start + 3) tudnam == array(start + 4, df) tudpage == array(start + 4034, pf) %end !END TMDMAP ! %routine udmap(%integer udstart) ! MAPS A PAGE IN USER DIRECTORY FORMAT udents == byteinteger(udstart + 5) udnext == byteinteger(udstart + 7) funnam == array(udstart + 8, ff) txtpage == array(udstart + 3908, xf) txtind == array(udstart + 3968, nf) %end !END UDMAP ! %routine tudmap(%integer start) tudents == byteinteger(start + 5) tudnext == byteinteger(start + 7) tfunnam == array(start + 8, ff) ttxtpage == array(start + 3908, xf) ttxtind == array(start + 3968, nf) %end ! END TUDMAP ! %routine txtmap(%integer txtstart) ! MAPS A PAGE IN TEXT FORMAT txtents == array(txtstart, sf) txtnext == byteinteger(txtstart + 3) fntxt == array(txtstart + 3, tf) %end !END TXTMAP ! ! %routine ttxtmap(%integer start) ttxtents == array(start, sf) ttxtnext == byteinteger(start + 3) tfntxt == array(start + 3, tf) %end ! %routine endmap ! MAPS LAST TEXT PAGE POINTERS endtxt == byteinteger(filstart + 4097) endind == array(filstart + 4098, sf) %end ! END ENDMAP ! %routine tendmap tendtxt == byteinteger(tstart + 4097) tendind == array(tstart + 4098, sf) %end !END TENDMAP ! %integer %fn shortint(%byte %integer %name index) ! RETURNS INTEGER VALUE HELD IN 2 BYTE ARRAY, INDEX %result = index << 8 ! byteinteger(addr(index) + 1) %end ! END SHORTINT ! %routine setshortint(%byte %integer %name name, %integer value) ! PUTS VALUE INTO 2 BYTE ARRAY, NAME name = value >> 8 byteinteger(addr(name) + 1) = value & X'FF' %end ! END SETSHORTINT ! %routine mapend ! MAPS LASR TEXT PAGE txtp = endtxt %unless txtp = 0 %then txtmap(filstart + txtp * 4096) %if txtp = 0 %or shortint(endind(1)) = 4093 %then %start getpage(4) endtxt = txtp endind(1) = 0 endind(2) = 1 %finish index = shortint(endind(1)) %end !END MAPEND ! %routine getudp udp = udpage(mdind) udmap(filstart + udp * 4096) %end ! %routine gettxtp(%integer ind) txtp = txtpage(ind) txtmap(filstart + txtp * 4096) %end ! ! ! ! LIST AREA AND LISTPRO PRIMITIVES ! ! LIST STRUCTURE IS HELD IN INTEGER ARRAY LA. A LIST IS REPRESENTED ! BY TWO ADJACENT ELEMENTS OF LA - THE FIRST POINTING TO THE HEAD ! THE SECOND POINTING TO THE TAIL. EACH ELEMENT CARRIES A MARKER ! IDENTIFYING IT AS A LIST ,A WORD OR A NUMBER. ! THE NULL LIST IS REPRESENTED BY A POINTER TO THE WORD "NIL" ! IN THE WORD AREA. ! ABSOLUTE POINTERS ARE USED IN LA AND ARE THUS ALWAYS POSITIVE, ! A LIST IS ADDRESSED BY AN INTEGER CARRYING A LIST MARKER AND A ! POINTER TO ITS FIRST LA ELEMENT - I.E. ITS HEAD. ! ! %integer %fn hd(%integer list) ! RETRIIEVES HEAD OF LIST %if list & lm = 0 %or list = nil %C %then baderror("NON-LIST ARG FOR HEAD - ", list) %result = la(list >> 8) %end ! END HD ! %routine rephead(%integer list, newhead) ! UPDATES HEAD OF LIST %if list & lm = 0 %or list = nil %C %then baderror("NON-LIST ARG FOR REPHEAD", list) la(list >> 8) = newhead %end ! END REPHEAD ! %integer %fn tl(%integer list) ! RETRIEVES TAIL OF LIST %if list & lm = 0 %or list = nil %C %then 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 %C %then baderror("NONLIST FIRST ARG FOR REPTAIL - ", list) %if newtail & lm = 0 %C %then baderror("NON-LIST SECOND ARG FOR REPTAIL - ", newtail) la(list >> 8 + 1) = newtail %end ! END REPTAIL ! %integer %fn 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 ! %integer %fn 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 %C %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 ! %integer %fn consg(%integer x, list) ! PATCH ROUTINE FOR ADDING STANDARD ! EMAS NUMBERS TO LISTS ! %result = cons(x << 8 ! nm, list) %end ! %integer %fn 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 %integer %fn amongq(%integer item, list) %result = 0 %if list = nil %result = 1 %if item = hd(list) %result = amongq(item, tl(list)) %end ! %integer %fn 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 !REVERSECOPYL1INTOL3 l2 = cons(hd(l3), l2) %and l3 = tl(l3) %while l3 # nil !ANDSTICKONFRONTOFL2 %result = l2 %end ! %integer %fn fromlist(%integer item, list) %integer newlist %if hd(list) = item %then %result = tl(list) newlist = list %while tl(newlist) # nil %cycle %if hd(tl(newlist)) = item %then %start reptail(newlist, tl(tl(newlist))) ! ALTERS LIST %result = list %finish newlist = tl(newlist) %repeat %result = list %end ! END OF FROMLIST ! ! ! ! ! GARBAGE COLLECTOR ! ! COLLECTION IS CARRIED OUT IF REQUIRED ON ENTRY TO EVAL ! WHEN MOST USER LIST STRUCTURE IS REFERENCED FROM THE USER STACK OR ! FROM THE ENVIRONMENT. WHERE NECESSARY, LIST REFERENCES FROM LOCAL ! IMP VARIABLES ARE TRANSFERRED TO THE SYSTEM STACK. ! COLLECTION INVOLVES ALTERING LABASE TO POINT TO THE BASE OF THE NEW ! SEMISPACEAND COPYING ALL ACTIVE LIST STRUCTURE TO THAT SEMISPACE. ! %routine collect(%integer envir) %integer %name freepointer %integer staddr, len %integer i, item, usedbefore, usedafter, collected ! %integer %fn 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 %then %C %result = list ! WORD,NUMBER OR LIST IN UNCOLLECTABLE SPACE %if hd(list) = -1 %then %result = 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 %then %start %cycle i = basenvir, 1, envir bvalue(i) = gencopy(bvalue(i)) %repeat %finish %if stkpnt > 0 %then %start %cycle i = 1, 1, stkpnt stk(i) = gencopy(stk(i)) %repeat %finish %if systkpnt > 0 %then %start %cycle i = 1, 1, systkpnt systk(i) = gencopy(systk(i)) %repeat %finish newfn = gencopy(newfn) ! COLLECT PICTURE LIST AREA NOW %cycle i = 0, 1, 1022 %if index42(i)_ptr # 0 %then index42(i)_ptr = gencopy(index42(i)_ptr) %repeat curpic = gencopy(curpic) curframe = gencopy(curframe) curmovie = gencopy(curmovie) ! usedafter = lpoint - labase %if status(masnum . "LOGOMON", 0) >= 0 %then %start define("7," . masnum . "LOGOMON") staddr = smaddr(7, len) freepointer == integer(staddr) %if freepointer + 48 > len %then -> close staddr = staddr + freepointer freepointer = freepointer + 48 string(staddr) = time . date string(staddr + 19) = emasuser integer(staddr + 28) = usedbefore integer(staddr + 32) = envir - basenvir integer(staddr + 36) = stkpnt integer(staddr + 40) = systkpnt integer(staddr + 44) = usedafter close: closesm(7) clear("7") disconnect(masnum . "LOGOMON") %finish clectflg = 0 collected = usedbefore - usedafter %if collected < 100 %C %then baderror("TOO FEW LIST CELLS COLLECTED", collected << 8 ! nm) %end ! END COLLECT ! %integer %fn copy(%integer list) ! USED TO COPY FROM UNCOLLECTABEL(FNSPACE) TO COLLECTABLE SPACE %integer mark mark = list & X'F0' %if list & lm # lm %or list & markermask = nil %then %result = list %result = cons(copy(hd(list)), copy(tl(list))) ! mark %end ! END COPY ! %integer %fn move1(%integer list) ! MOVE1 IS USED TO COPY LIST STRUCTURE CREATED BY THE READER IN ! COLLECTABLE SPACE TO UNCOLLECTABLE SPACE. NO CIRCULAR/BLAM LISTS ! %integer %fn copy1(%integer list) %integer mark mark = list & X'F0' %if list & lm # lm %or list & markermask = nil %then %result = list %result = cons1(copy1(hd(list)), copy1(tl(list))) ! mark %end ! END COPY1 ! %if list & lm # lm %then baderror("NON-LIST ARG FOR MOVE1 - ", list) %if (list >> 8) >= lafnb %then %result = list ! ALREADY IN FNSPACE %result = copy1(list) %end ! END MOVE ! %integer %fn reverse(%integer list) %integer list1 list1 = nil %while list & markermask # nil %cycle list1 = cons(hd(list), list1) list = tl(list) %repeat %result = list1 %end ! END REVERSE ! %integer %fn reverse1(%integer list) %integer list1 list1 = nil %while list & markermask # nil %cycle list1 = cons1(hd(list), list1) list = tl(list) %repeat %result = list1 %end ! OF REVERSE1 ! ! ! ! ENVIRONMENT ! ! VARIABLE BINDINGS ARE HELD AS (NAME,VALUE) PAIRS IN ARRAYS ! BNAME AND BVALUE. THE CURRENT ENVIRONMENT IS DEFINED BY ENVIR ! WHICH POINTS TO THE TOP OF THE LAST ENVIRONMEBT CREATED, ! OR IS EQUAL TO 1022 IF ONLY THE BASE ENVIRONMENT EXISTS. ! WHENEVER A LOGO FUN IS APPLIED, THE PARAMETER NAMES AND LOCAL ! NAMES ARE INSERTED IN A NEWLY CREATED ENVIRONMENT TOGETHER WITH ! A SINGLE DIAGNOSTIC RECORD (THE FIRST) WHICH HAS 0 AS ITS NAME ! COMPONENT. ! SUCH LOCAL ENVIRONMENTS ARE CREATED UPWARDS FROM 1023. ! BVALUE(0-1022) IS USED FOR THE BASE ENVIRONMENT VALUES. ! THIS PART OF BVALUE IS PARALLEL TO WA AND IS ACCESSED ! BY DIRECT APPLICATION OF THE WORD INDEX. ! BASENVIR IS USED TO REFER TO THE BASE ENVIR ! VARIABLE UNDEF CONTAINS A POINTER TO THE WORD "UNDEF" IN THE WORD ! AREA. ! FUNCTION UNSTACK RETREIVES THE TOP ELEMENT FROM THE LOGO STACK. ! VARIABLE NIL POINTS TO THE EMPTY LIST-THE WORD "NIL". ! VARIABLE DOTS POINTS TO THE WORD ':'. ! ! %integer %fn 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 %then %start ! SKIP DIAGNOSTIC RECORD AT START envir = envir - 1 -> local %finish %if bname(envir) = name %then %result = envir ! FOUND IT envir = envir - 1 %repeat name = name >> 8 ! NOT LOCAL SO TRY GLOBAL %if bvalue(name) = 0 %then %result = undef %else %result = 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 %then %start ! NOT YET DEFINED bvalue(name >> 8) = value ! SO CREATE IT GLOBALLY %finish %else bvalue(binding) = value ! ALREADY DEFINED SO UPDATE IT %end ! END SETVAL ! %integer %fn getval(%integer name, envir) ! RETRIEVES A BINDING %integer binding binding = findbind(name, envir) %if binding = undef %then %result = undef %else %result = bvalue(binding) %end ! END GETVAL ! %integer %fn setbind(%integer parmlist, envir) ! BINDS PARMATER NAMES AND ARGS IN NEW ENVIRONMENT ! PARAMETER NAMES ARE IN PARMLIST IN ORDER. ! ARG VALUES ARE ON STACK %while parmlist # nil %cycle %if envir = 3000 %then baderror("ENVIRONMENT OVERFLOW", empty) envir = envir + 1 bname(envir) = hd(parmlist) %if checkstack = fault %then %result = fault bvalue(envir) = unstack parmlist = tl(parmlist) %repeat %if envir > topmark %then topmark = envir ! TOPMARK USED BY DUMP %result = envir %end ! END SETBIND ! %integer %fn 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 ! %integer %fn 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; ! %integer %fn checkstack %if stkpnt = 0 %then %result = fault %result = 0 %end ! ! ! SYSTEM STACK ! USED TO MAKE REFS TO COLLECTABLE LIST STRUCTURE FROM IMP LOCALS ! AVAILABLE TO THE COLLECTOR. ! %integer %fn unstksys %if systkpnt = 0 %then baderror("SYSTACK UNDERFLOW", empty) systkpnt = systkpnt - 1 %result = systk(systkpnt + 1) %end ! END UNSTKSYS ! %routine stksys(%integer i) %if systkpnt = 2000 %then baderror("SYSTACK OVERFLOW", empty) systkpnt = systkpnt + 1 systk(systkpnt) = i %end ! END STKSYS ! ! ! ! SYSTEM INPUT/OUTPUT ! ! ALL SYSTEM INPUT IS IN THE FORM OF A LIST WITH OUTERMOST ! BRACKETS IMPLICIT. SPACES AND NOOLINE AT START OF INPUT ARE ! DISCARDED OTHERWISE THEY SERVE TO DELIMIT WORDS. THE LIST IS ! TERMINATED WITH A SEMI COLON ! AT LEVEL 1 (IE USER LEVEL ZERO),THE MINUS CHAR IS LEFT ! AS A SEPARATE WORD. AT ANY OTHER LEVEL IT IS ASSUMED TO BE ! THE UNARY MINUS AND MUST BE FOLLOWED BY A NUMBER. THE NUMBER ! IS THEN CONVERTED TO BINARY AND NEGATED. ! ! %routine chkind(%integer %name index) ! CHECKS INDEX FOR READ ROUTINES %if index > shortint(txtents(1)) %then %start %if txtnext = 0 %then %start baderror("NEXT TEXT PAGE NOT INDICATED", empty) %finish txtp = txtnext txtmap(filstart + txtp * 4096) index = 1 %finish %end !END CHKIND ! ! ! INPUT ROUTINES -- READ SYMBOL FROM INPUT BUFFER ! INPTR IS A POINTER TO CURRENT POSITION IN LINE ! %routine lgreadsym(%integer %name sym) ! READ SYMBOL FROM INPUT BUFFER sym = inbuff(inptr) inptr = inptr + 1 %return %end ! END LGREAD SYM ! %integer %fn lgnextsym ! NEXT SYMBOL FROM INPUT BUFFER %result = inbuff(inptr) %end ! END LGNEXT SYM ! %routine lgskipsym ! SKIP SYMBOL IN INPUT BUFFER inptr = inptr + 1 %return %end ! END LGSKIP SYM ! %routine lgreaditem(%string %name item) ! READ ITEM FROM INPUT BUFFER item = tostring(inbuff(inptr)) inptr = inptr + 1 %return %end !END LGREAD ITEM ! ! %integer %fn getitem ! ! READ NEXT LOGO ITEM FROM INPUT BUFFER ! %integer sym, skipmark %string (2) item %string (64) word %integer symcount symcount = 0 word = "" skipmark = 0 %if quoteon = 1 %and (lgnextsym < "0" %or "9" < lgnextsym < "A" %C %or lgnextsym > "Z") %then %result = empty lp: %if lgnextsym = " " %then %start lgskipsym %if symcount = 0 %then -> lp %else %start %if skipmark = 1 %then nooline(1) %result = put(word) %finish %finish %if lgnextsym = '@' %then %start %if symcount = 0 %then %start lgskipsym ! SKIP @ lgskipsym %if lgnextsym = nl ! SKIP NL -> lp %finish %else %start %if skipmark = 1 %then nooline(1) %result = put(word) %finish %finish %if lgnextsym = termin %then %start ! TERMIN=NL %if symcount = 0 %then %start %if level > blevel %or parlevel > blevel %then %start prstring("MISSING RIGHT BRACKET INSERTED") nooline(1) %finish level = blevel parlevel = blevel %result = rbrak %finish %else %start %if skipmark = 1 %then nooline(1) %result = put(word) %finish %finish %if lgnextsym = lbrak %or lgnextsym = rbrak %then %start %if symcount = 0 %then %start lgreadsym(sym) %if sym = lbrak %then level = level + 1 %else level = level - 1 %result = sym %finish %else %start %if skipmark = 1 %then nooline(1) %result = put(word) %finish %finish %if lgnextsym = '-' %and level # 1 %then %start %if symcount = 0 %then %start lgskipsym sym = getitem %if sym & nm = 0 %then %start prstring("INVALID '-' BEFORE ") printel(sym) space prstring("IGNORED") nooline(1) %finish %else %start %result = (-sym >> 8) << 8 ! nm %finish %finish %else %start %if skipmark = 1 %then nooline(1) %result = put(word) %finish %finish %if lgnextsym < 48 %or (lgnextsym > 57 %and lgnextsym < 65) %C %or lgnextsym > 90 %then %start %if symcount = 0 %then %start lgreaditem(item) %if (item = "<" %or item = ">") %and lgnextsym = '=' %then %start item = item . "=" lgskipsym %finish %if item = "<" %and lgnextsym = '<' %then %start item = "<<" lgskipsym %finish %if item = ">" %and lgnextsym = '>' %then %start item = ">>" lgskipsym %finish %result = put(item) %finish %else %start %if skipmark = 1 %then nooline(1) %result = put(word) %finish %finish lgreaditem(item) %if symcount = 64 %then %start %if skipmark = 1 %then prstring(item) %else %start skipmark = 1 prstring("EXCESS CHARS IGNORED - ") prstring(item) %finish %finish %else %start word = word . item symcount = symcount + 1 %finish -> lp %end ! END GETITEM ! ! INPUT BUFFER IS THOUGHT OF AS A LIST. ! HEADIN IS THE HEAD OF THE LIST ! TAILIN CAUSES HEADIN TO BE UPDATED TO NEXT ITEM ON LIST ! UNUSEDHD IS A FLAG USED BY PARSE ROUTINES TO CHECK ! WHETHER THE HEAD OF THE INPUT LIST HAS BEEN PROCESSED ! %routine tailin headin = getitem unusedhd = 0 %end ! OF TAILIN ! ! ! INPUT ROUTINES FROM CURRENT INPUT STREAM ! THIS IS EITHER .TT, SOURCETEXT, FILESTORE ! %routine readinsym(%integer %name sym) ! LOGO READ SYMBOL %if device = tty %then readsymbol(sym) %else %start %if device = srce %then %start sym = source(sindex) sindex = sindex + 1 %finish %else %start chkind(index) sym = fntxt(index) index = index + 1 %finish %finish %end ! END OF READ IN SYM ! %integer %fn nextinsym ! LOGO NEXT SYMBOL %if device = tty %then %result = nextsymbol %if device = srce %then %result = source(sindex) chkind(index) %result = fntxt(index) %end ! END OF NEXT IN SYM ! %routine skipinsym ! LOGO SKIP SYMBOL %if device = tty %then skipsymbol %and %return %if device = srce %then sindex = sindex + 1 %else index = index + 1 %end ! END OF SKIP IN SYMBOL ! %routine readinline(%string (15) promp) ! ! READ A LINE FROM CURRENT INPUT STREAM TO INPUT BUFFER ! %integer ptr, sym level = blevel parlevel = blevel prompt(promp) ptr = 1 skipinsym %while nextinsym = nl %until nextinsym = nl %cycle %if ptr >= 255 %then %start prstring("LINE TOO LONG") nooline(1) %exit %finish readinsym(sym) inbuff(ptr) = sym ptr = ptr + 1 %if sym = '@' %then %start %while nextinsym # nl %cycle skipinsym %repeat %if ptr >= 255 %then %start prstring("LINE TOO LONG") nooline(1) %exit %finish readinsym(sym) inbuff(ptr) = sym ptr = ptr + 1 prompt("C:") %finish %repeat inbuff(ptr) = nl prompt(promp) inbuff(0) = ptr inptr = 1 headin = getitem unusedhd = 0 %if headin = rbrak %then readinline(promp) %end ! END OF READ LINE ! ! %routine copyline ! ! COPY A LINE FROM INPUT BUFFER INTO SOURCE TEXT FILE ! %if sourceptr + inbuff(0) > maxsource %C %then baderror("FILE SOURCE SPACE OVERFLOW", empty) move(inbuff(0), addr(inbuff(1)), addr(source(sourceptr))) sourceptr = sourceptr + inbuff(0) %end ! ! %integer %fn readlist ! ! READ A LIST FROM INPUT BUFFER ! RESULT IS HEAD OF LIST ! %integer thispoint, item thispoint = lpoint item = headin tailin !%IF ITEM=QUOTE %THEN QUOTEON=1 %ELSE QUOTEON=0 %if item = rbrak %then %start unusedhd = 1 %result = nil %finish %else %start lpoint = lpoint + 2 %if (lpoint - labase) > cfract * semisize %then clectflg = 1 ! SET FLAG FOR COLLECT %if item = lbrak %then %start la(thispoint) = readlist %finish %else la(thispoint) = item la(thispoint + 1) = readlist %result = thispoint << 8 ! lm %finish %end ! OF READLIST ! ! %integer %fn readline blevel = 1 readinline(promp) %result = readlist %end ! END READLINE ! %routine getpage(%integer flag) ! GETS A NEW PAGE ! FLAG 1 - NEW MASTER DIRECTORY PAGE ! FLAG 2 - NEW USER DIRECTORY PAGE ! FLAG 4 - NEW TEXT PAGE ! FLAGS MAY BE COMBINED %string (10) size %integer len, i, j, k i = (flag & 1) + ((flag & 2) // 2) + ((flag & 4) // 4) size = numtostr((flen + 4096 * i) << 8) define("10,T#JUNK") newsmfile("T#JUNK," . size) tstart = smaddr(10, len) %cycle i = 0, 4096, flen - 4096 ! COPY OLD FILE TO NEW FILE j = filstart + i k = tstart + i move(4096, j, k) %repeat closesm(10) clear("10") closesm(4) clear("4") destroy(masfile) rename("T#JUNK," . masfile) cherish(masfile) permit(masfile . ",,R") permit(maswrite) getmaster mdmap(filstart + mdp * 4096) %if flag = 4 %then %start endmap %unless txtp = 0 %then txtmap(filstart + txtp * 4096) %C %and txtnext = len // 4096 - 1 txtp = len // 4096 - 1 txtmap(filstart + txtp * 4096) txtents(1) = 0 txtents(2) = 0 index = 1 txtnext = 0 %finish %else %start %if flag = 3 %then %start mdents = 63 mdnext = len // 4096 - 2 mdp = mdnext mdmap(filstart + mdp * 4096) mdents = 0 %finish %unless udp = 0 %then %start udmap(filstart + udp * 4096) udents = 61 udnext = len // 4096 - 1 %finish udp = len // 4096 - 1 udmap(filstart + udp * 4096) udents = 0 endmap %if udp = 1 %then endtxt = 0 %and setshortint(endind(1), 1) %finish %end ! END GETPAGE ! %routine nooline(%integer n) %while n > 0 %cycle newline n = n - 1 %repeat charout = 0 %end ! END NOOLINE ! %routine prstring(%string (255) word) %integer n n = length(word) %if (charout + n) > 72 %then %start newline %if word -> (" ") . word %then n = n - 1 spaces(3) printstring(word) charout = n + 3 %finish %else %start printstring(word) charout = charout + n %finish %end ! END PRSTRING ! %routine lgprntstr(%string (64) word) %integer save, newind %if device = tty %then prstring(word) %and %return %if device = srce %then %start save = source(sourceptr - 1) string(addr(source(sourceptr - 1))) = word newind = sourceptr + source(sourceptr - 1) source(sourceptr - 1) = save sourceptr = newind %finish !%IF 4093-INDEX> 8) & X'FFFF') printword(word) %end ! END PRINTWN ! %routine printlcon(%integer list) %integer i lp: %if enuf = 1 %or (interrupt = "ENUF" %and device = tty) %then %start enuf = 1 %return %finish %if list = nil %then %return i = hd(list) %if i & lm = lm %then printlist(i) %else printwn(i) list = tl(list) -> lp %end ! END PRINTLCON ! %routine printlist(%integer list) sep = "" printword("[") printlcon(list) printword("]") %end ! END PRINTLIST ! %routine printel(%integer i) %integer j enuf = 0 sep = "" %cycle j = 1, 1, 14 %if spechar(j) = i %then -> spchar %repeat %if i & lm = lm %then printlist(i) %else printwn(i) %return spchar: printword(tostring(i)) %end ! END PRINTEL ! %routine printline(%integer line) %integer head sep = "" %if line = nil %then %start enuf = 0 printlist(nil) %finish %while line # nil %cycle head = hd(line) %if head & lm = lm %then %start enuf = 0 printlist(head) %finish %else printwn(head) line = tl(line) %repeat lgnewline %end ! END PRINTLINE ! %routine printfnline(%integer %name sptr) %integer sym, i, cont cont = 0 %if device = tty %then %start %cycle i = 0, 1, 255 sym = source(sptr + i) printsymbol(sym) %if sym = '@' %then %start %cycle sym = source(sptr + i + 1) %if sym = nl %then %exit printsymbol(sym) sptr = sptr + 1 %repeat cont = 1 %finish %else %start %if sym = nl %then %start %exit %unless cont = 1 cont = 0 %finish %finish %repeat %finish %else %start %cycle i = 0, 1, 255 %if index = 4093 %then setshortint(txtents(1), 4092) %C %and getpage(4) sym = source(sptr + i) fntxt(index) = sym index = index + 1 %if sym = '@' %then %start %while source(sptr + i + 1) # nl %cycle sptr = sptr + 1 %repeat cont = 1 %finish %if sym = nl %then %start %exit %unless cont = 1 cont = 0 %finish %repeat setshortint(txtents(1), index - 1) %finish sptr = sptr + i + 1 %if i = 255 %then %start prstring("LINE TOO LONG - TRUNCATED") %if device = tty %then printsymbol(nl) %else fntxt(index - 1) = nl nooline(1) %finish %end ! END OF PRINTFNLINE ! %routine printhex(%byte %integer i) %const %byte %integer %C %array hex(0 : 15) = '0', '1', '2', '3', '4', '5', '6', '7', '8', %C '9', 'A', 'B', 'C', 'D', 'E', 'F' %integer cyc %string (2) h h = "" %cycle cyc = 0, 1, 1 h = tostring(hex((i >> (cyc * 4)) & 15)) . h %repeat printstring(h) %end ! ! ! ! INFERENCE SYSTEM ! %routine setupinf bvalue(database >> 8) = nil bvalue(factkeys >> 8) = nil bvalue(imprules >> 8) = nil bvalue(impkeys >> 8) = nil bvalue(infrules >> 8) = nil bvalue(infkeys >> 8) = nil genos = 0 %end ! END SETUPINF ! %routine initinf dbase(1) = database implinks(1) = imprules inflinks(1) = infrules dbase(2) = fact implinks(2) = implies inflinks(2) = toinfer dbase(3) = factkeys implinks(3) = impkeys inflinks(3) = infkeys setupinf %end ! END INITINF ! ! ! ! EVAL AND APPLY ! %integer %fn findlinenums(%integer list) ! ! SEARCHES LINE NUMBER LIST IN USER PROCEDURE FOR THE NUMBER ! THAT IS AT TOP OF STACK ! %integer num num = unstack %while list # nil %cycle %if hd(hd(list)) = num %then %start goflag = 0 stack(num) %result = tl(hd(list)) %finish list = tl(list) %repeat stack(num) %result = 0 %end ! ! ! %integer %fn %spec checkfnhead(%integer %name name) %routine %spec parseerr(%integer errmess, culprit) %routine edit(%integer %name name) %integer sstart, slen, wsp, lwsp, flag, userfun userfun = name >> 8 sstart = addr(source(fntext(userfun))) ! ADDR OF START OF USER TEXT slen = fnlen(userfun) ! LENGTH OF CURRENT TEXT wsp = addr(source(sourceptr)) ! ADDR OF START OF FREE SPACE lwsp = maxsource - sourceptr + 1 ! LENGTH OF AVAILABLE FREE SPACE prompt(">") edinner(sstart, slen, sstart, slen, wsp, lwsp) ! ENTER ECCE prompt(promp) ! RESET PROMPT fntext(userfun) = sourceptr ! STORE ADDR OF NEW DEFN fnlen(userfun) = lwsp sourceptr = sourceptr + lwsp %if lwsp > 4 %then %start %cycle wsp = 5, 1, lwsp %if source(sourceptr - wsp) = nl %then -> chend %repeat %finish chend: %if source(sourceptr - wsp + 1) = 'E' %C %and source(sourceptr - wsp + 2) = 'N' %C %and source(sourceptr - wsp + 3) = 'D' %then -> chfnhd insend: %if sourceptr + 4 > maxsource %C %then baderror("SOURCE FILE SPACE OVERFLOW", empty) source(sourceptr) = 'E' source(sourceptr + 1) = 'N' source(sourceptr + 2) = 'D' source(sourceptr + 3) = nl sourceptr = sourceptr + 4 fnlen(userfun) = lwsp + 4 prstring("END INSERTED") nooline(1) chfnhd: flag = checkfnhead(name) ! CHECK NEW PROCEDURE HEADER %if flag = fault %then fnparse(name >> 8) = 255 %end ! ! %integer %fn %spec countargs %integer %fn checkfnhead(%integer %name userfun) %integer fn, savedev, numargs, res, fnspec res = 0 numargs = 0 fnparse(userfun >> 8) = 0 fnval(userfun >> 8) = userpre savedev = device ! CHECK FIRST LINE device = srce sindex = fntext(userfun >> 8) readinline(promp) device = savedev %if headin # to %then %start ! CHECK THAT DEFN STARTS WITH TO parseerr(-17, userfun) ! INVALID FN DEFN - TO MISSING res = fault -> exit %finish tailin fn = headin %if fn & wm # wm %then %start ! CHECK THAT NAME OF PROC IS A WORD parseerr(-14, fn) res = fault -> exit %finish %if fn # userfun %then %start ! NAME CHANGED newfn = fromlist(fn, newfn) %unless newfn = nil fnspec = fnval(fn >> 8) ! GET SPEC %unless fnspec = 0 %or fnspec & userpre = userpre %then %start parseerr(-15, fn) res = fault -> exit %finish %if fntext(fn >> 8) # 0 %C %then oldfn(fn >> 8) = fnlen(fn >> 8) << 16 ! fntext(fn >> 8) fntext(fn >> 8) = fntext(userfun >> 8) fnlen(fn >> 8) = fnlen(userfun >> 8) fnparse(fn >> 8) = fnparse(userfun >> 8) fntext(userfun >> 8) = 0 fnlen(userfun >> 8) = 0 fnval(userfun >> 8) = 0 userfun = fn %finish tailin numargs = countargs %if numargs > 127 %then %start parseerr(-13, userfun) res = fault -> exit %finish %if numargs < 0 %then res = fault %and numargs = 0 exit: fnval(userfun >> 8) = userpre + numargs ! TEMP SPEC TO ALLOW RECURSIVE CALLS %result = res %end ! %integer %fn countargs ! ! COUNT NO OF ARGS IN A USER PROCEDURE. ! %integer len len = 0 %while headin # rbrak %cycle -> errlab %unless headin = quote tailin -> errlab %if headin & wm # wm %or headin = rbrak len = len + 1 tailin %repeat %result = len errlab: parseerr(-16, empty) %result = fault %end ! OF COUNTARGS ! ! ! ! %routine parseerr(%integer errmess, culprit) %integer savedev, errnum %const %string (80) %array message(1 : 22) = %C "NAME MISSING AFTER : ", %C "NON-WORD AFTER : - ", %C "MISSING >> ", %C "MISPLACED CLOSING BRACKET - ", %C "MISPLACED INFIX FN ", %C "THEN MISSING - ", %C "THEN NOT FOUND - ", %C "FINISH MISSING - ", %C "NO NUMBER ON FN LINE - LINE IGNORED - ", %C "ERROR IN FN TYPE ", %C "UNDEFINED PROCEDURE ", %C "NOT ENOUGH ARGS FOR - ", %C "TOO MANY ARGS FOR ", %C "TO MUST BE GIVEN A WORD AS PROCEDURE NAME - ", %C "YOU CAN'T REDEFINE A SYSTEM PROCEDURE - ", %C "INCORRECT FORMAT FOR ARGS ", %C "INCORRECT FORMAT FOR FN DEFN - TO MISSING - ", %C "RUN OUT OF FILE SPACE ", %C "FN DEFN NOT AT OUTER LEVEL", %C "LINE IGNORED - ", %C "CONDITION CLAUSE MISSING", %C "THEN CLAUSE MISSING" errnum = -errmess savedev = device device = tty prstring(message(errnum)) space printel(culprit) nooline(1) device = savedev %end ! ! %integer %fn %spec parseline(%integer prec) %routine evalappl(%integer %C %name envir, fun, curfun, in, tstflg, val, severity) ! ! ENVIR IS THE CURRENT ENVIRONMENT POINTER - 1022 IF OUTSIDE A USER ! FUN AND ONLY BASE ENVIR EXISTS. ! FUN IS THE USER FUN WE ARE CURRENTLY IN - NIL IF OUTSIDE USER ! FUN ! CURFUN IS THE LINE OF THE USER FUN WE ARE CURRENTLY IN - NIL ! IF OUTSIDE USER FUN ! IN CONTAINS THE LINE WE ARE CURRENTLY EVALUATING EITHER FROM ! A USER FUN OR FROM THE TTY ! TSTFLG IS THE CURRENT TEST LOCATION USED BY TEST IFTRUE,ETC ! VAL IS THE LAST VALUE ! SEVERITY IS USED IN APPLYSYS TO TELL IF A CONTINUE ! IS POSSIBLE ! ! THESE PARAMETES ARE CREATED BY LOGO AT BASE LEVEL AND ARE ! RECREATED BY APPLYUSR ON EACH ENTRY TO USER FUN. ! THEY ARE USED FREE BY ROUTINE ERROR FOR DIAGNOSTIC PURPOSES ! AND BY APPLYSYS AND EVAL ! %routine %spec eval(%integer in, %integer %name eachval) ! ! %routine error(%string (80) errmess, %integer culprit, severity, %C %integer %name in) %integer savedev, txtptr %if tdev = 8 %then set42(chtxt) savedev = device device = tty nooline(1) prstring(errmess) space printel(culprit) nooline(1) %if fun = nil %then -> err1 ! NOT IN A USER FUN prstring("IN ") printel(hd(tl(hd(fun)))) ! NAME OF USER FUN nooline(1) %unless curfun = nil %then %start txtptr = (hd(curfun) >> 16) & X'FFFF' printfnline(txtptr) !PRINTLINE(HD(CURFUN)); ! CURRENT LINE nooline(1) %finish %if getval(quitotop, envir) = false %then %start ! ENTER LOGO RECURSIVELY stksys(in) stksys(val) logo(stkpnt, makebind(nil, envir, logoname), severity) val = unstksys in = unstksys ! IN NEEDS TO BE AVAILABLE TO THE COLLECTOR ONLY IN THE SINGLE !CASE WHERE IT IS THE ARGUMENT PASSED FROM DOLOGO. IN ALL OTHER ! CASES IT WILL BE A REFERENCE TO THE UNCOLLECTABLE FNSPACE. THE ! COLLECTOR CHECKS THAT THE REFERENCES ON SYSTK ARE IN FACT TO ! COLLECTABLE SPACE device = savedev %return %finish err1: jumpflag = 1 ! TRIGGERS A RETURN TO LOGO in = nil stack(err) device = savedev %end ! END ERROR ! %routine error1(%string (80) errmess, %integer culprit) %integer savedev savedev = device device = tty prstring(errmess) space printel(culprit) nooline(1) device = savedev %end ! END ERROR1 ! %integer %fn negate(%integer i) %if i & nm # nm %then %start prstring("INVALID UNARY MINUS BEFORE ") printel(i) prstring(" IGNORED") nooline(1) %result = i %finish %if i < 0 %then %result = (-i >> 8 ! t8) << 8 ! nm %else %C %result = (-i >> 8) << 8 ! nm %end ! END NEGATE ! ! %routine chklist(%integer list) %integer word %if list & lm # lm %then %start error("NEW CANNOT HAVE A NUMBER AS ARGUMENT - ", list, 1, in) %return %finish %while list # nil %cycle %if quitflag = 1 %then %start quitflag = 0 jumpout = 0 jumpflag = 1 stack(quit) %return %finish %if holdflag = 1 %then %start holdflag = 0 stksys(list) error("USER INTERRUPT", empty, 0, in) list = unstksys %if jumpflag = 1 %then %return %finish word = hd(list) %if word & wm # wm %then %start error(" NEW MUST HAVE A WORD AS ARGUMENT - ", word, 1, in) %return %finish list = tl(list) %repeat %end ! END CHKLIST ! ! %integer %fn 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 ! %integer %fn getmatch(%integer %name 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 %then %start in = tl(in) clause = cons(head, clause) %result = empty %finish %if head = lpar %then %start res = getmatch(clause, in) %if res # empty %then %result = res ! PASS ERROR OUT %finish %else %start ! NEITHER LPAR NOR RPAR SO CONTINUE in = tl(in) clause = cons(head, clause) %finish %repeat %result = rpar ! NO RPAR BEFORE END %end ! END GETMATCH ! %routine strtrace(%integer fn) ! USED TO PRINT FN. NAME ETC WHEN ENTERING A TRACED FN indent = indent + 1 spaces(indent) printstring(">") printel(fn) nooline(1) indent = indent + 1 %end ! END STRTRACE ! %routine endtrace(%integer fn) ! USED TO PRINT FN NAME ETC. WHEN EXITING A TRACED FN indent = indent - 1 spaces(indent) printstring("<") printel(fn) nooline(1) indent = indent - 1 %end ! END ENDTRACE ! %routine sendbin(%byte %integer type, n) ! IF TYPE=0, N 16 BIT ARGS ALREADY SET UP IN BINARG1,2,ETC ! IF TYPE=1 N IS IRRELEVANT n = 2 * n binbuff(1) = tdev - 1 binbuff(2) = type %if type = 0 %then %start binbuff(3) = n !@#$ P_ARG3=N+3 %finish !@#$ ELSE P_ARG3=2 !@#$ P_DEST=208; ! SVC PUT OUTPUT !@#$ P_ARG1=16; ! CHANNEL 0 WITH BINARY NIT !@#$ P_ARG2=ADDRBINBUFF !@#$ DOSVC:SVC(P) !@#$ %IF P_ARG1<0 %THENSTART; ! ABORTED !@#$ P_ARG1=P_ARG2 !@#$ P_ARG2=P_ARG3 !@#$ P_ARG3=P_ARG4 !@#$ P_DEST=208 !@#$ ->DOSVC !@#$ %FINISH %end ! END SENDBIN ! %routine binarg(%integer argn, val) ! BINARY ARG IS LEAST SIG, 16 BITS OF VAL ! ARG1==BINBUFF(4) AND(5) ! ARG2==BINBUFF(6) AND (7) ! ETC %integer i i = 2 * argn + 2 ! BINBUFF LOWER INDEX binbuff(i) = (val >> 8) & X'FF' binbuff(i + 1) = val & X'FF' %end ! END BINARG ! %routine cleset ! CLEARS AND RSETS TURTLE DEVICE (IE CLEARS H316 Q) %if tdev = 8 %then clear42 sendbin(1, 0) xturtle = 0 yturtle = 0 hdturtle = 0 penturtle = down %end ! END CLESET ! ! ! ! ! ! %routine applysys(%integer sw, %integer %name fn, in, eachval) ! %routine %spec addfact(%integer fact, indent) %integer %fn %spec deduceq(%integer pattern, indent) %integer %fn %spec 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, %C sethsw, posw, arclsw, arcrsw, pnsw, rnsw, notesw, playsw, %C motasw, motbsw, rotsw, pairsw(0:8) %real rw1, rw2 %real dx, dy %integer xc, yc ! TURTLE WORKSPACE %integer arg1, arg2, arg3, arg4, w1, w2, w3, w4 %integer savedev, starttext %integer cond, tbranch, fbranch, res, condlist %real %array tstor(1 : 2) ! USED IN "PICTURE" TO HOLD TURTLE COORDS %integer %array tstori(3 : 4) %integer %array movierecord(1 : frametime) %integer currentmovietime %integer %name wptr1 %integer redef ! USED BY ABBREV %string (64) wstr1, wstr2 %routine %spec vector(%real x, y) %routine %spec calcturtle ! ! %integer %fn evalstartfin(%integer branch) %integer lnumbers, polist branch = tl(branch) lnumbers = hd(branch) ! LINE NUMBER LIST branch = tl(branch) evalnextline: polist = tl(hd(branch)) %cycle %unless polist = nil %then %start %exit %if hd(polist) = finish %result = nil %if branch = nil stksys(in) stksys(condlist) stksys(lnumbers) stksys(branch) eval(polist, eachval) branch = unstksys lnumbers = unstksys condlist = unstksys in = unstksys %if jumpflag = 1 %then %result = nil %if goflag = 1 %then %exit ! JUMP INSTR val = unstack %if fun # nil %and curfun = nil %then %result = val %finish branch = tl(branch) polist = tl(hd(branch)) %repeat %if goflag = 1 %then %start ! JUMP branch = findlinenums(lnumbers) ! FIND LINE WITH THIS LABEL %if branch = 0 %then %result = nil ! LABEL NOT FOUND AT THIS LEVEL val = unstack -> evalnextline %finish ! FINISH JUMP %result = val %end ! OF EVALSTARTFIN ! ! %integer %fn %spec equal(%integer l1, l2) %integer %fn findass(%integer list, att) ! FINDS AN ASSOCIATION IN LIST WITH ATTRIBUTE ATT. USES W1 AND W2 ! FREE. IF ASSOC FOUND, W2 POINTS TO LIST STARTING WITH ASSOC AND ! W1 POINTS TO ONE BEFORE, UNLESS ASSOC IS FIRST IN LIST WHEN W1=W2 ! IN EITHER CASE W2 ALSO RETURNED VIA RESULT. ! IF NO ASSOC FOUND, NIL RETURNED. w1 = list w2 = list %while w2 # nil %cycle %if equal(hd(hd(w2)), att) = false %then %start w1 = w2 w2 = tl(w2) %finish %else %result = w2 %repeat %result = nil %end ! END FINDASS ! %routine checknum %if arg1 & nm # nm %or arg2 & nm # nm %C %then error("ARITHMETIC REQUIRES NUMBERS - ", cons(arg1, %C cons(arg2, nil)), 1, in) %return %end ! END CHECKNUM ! %integer %fn checksize(%integer i) %if i > numtop %then %start prstring("ARITHMETIC RESULT OUT OF RANGE.") write(i, 0) space prstring("MAX SUBSTITUTED") nooline(1) %result = numtop %finish %if i < numbot %then %start prstring("ARITHMETIC RESULT OUT OF RANGE. MIN SUBSTITUTED") nooline(1) %result = numbot %finish %result = i %end ! END CHECKSIZE ! %routine checksum(%integer arg1, arg2) !CHECKS THAT ARG1+ARG2 DOES NOT EXCEED IMP LIMIT %if arg1 > 0 %then %start %if arg2 > 0 %and maxint - arg1 < arg2 %then %start error("INTEGER OVERFLOW IN SUM/DIFFERENCE", empty, 1, in) %return %finish %finish %else %start %if arg2 < 0 %and maxint + arg2 < imod(arg1) %then %start error("INTEGER OVERFLOW IN SUM/DIFFERENCE", empty, 1, in) %return %finish %finish %end ! END CHECKSUM ! %routine readynum arg1 = unstack arg2 = unstack checknum %if jumpflag = 1 %then %return %if arg1 < 0 %then arg1 = arg1 >> 8 ! t8 %else arg1 = arg1 >> 8 %if arg2 < 0 %then arg2 = arg2 >> 8 ! t8 %else arg2 = arg2 >> 8 %end ! END READYNUM ! %routine word %if arg1 & lm = lm %or arg1 < 0 %then %start error("WORD MUST HAVE A WORD OR NON-NEGATIVE NUMBER AS ARGUMENT - ", arg1, 1, in) %return %finish %if arg2 & lm = lm %or arg2 < 0 %then %start error("WORD MUST HAVE A WORD OR NON-NEGATIVE NUMBER AS ARGUMENT - ", arg2, 1, in) %return %finish %if arg1 & nm = nm %then wstr1 = numtostr(arg1) %C %else wstr1 = wa(arg1 >> 8) %if arg2 & nm = nm %then wstr2 = numtostr(arg2) %C %else wstr2 = wa(arg2 >> 8) %if length(wstr1) + length(wstr2) > 64 %then %start error("WORD LENGTH EXCEEDED - ", cons(arg1, cons(arg2, nil)), %C 1, in) %return %finish stack(put(wstr1 . wstr2)) %return %end ! END WORD ! %routine lastput %if arg2 & lm # lm %then %start error("LASTPUT MUST HAVE A LIST AS SECOND ARGUMENT - ", arg2, %C 1, in) %return %finish arg3 = nil %while arg2 # nil %cycle %if quitflag = 1 %then %start quitflag = 0 jumpout = 0 jumpflag = 1 stack(quit) %return %finish %if holdflag = 1 %then %start holdflag = 0 stksys(arg2) stksys(arg3) error("USER INTERRUPT", empty, 0, in) arg3 = unstksys arg2 = unstksys %if jumpflag = 1 %then %return %finish arg3 = cons(hd(arg2), arg3) arg2 = tl(arg2) %repeat ! ARG3 NOW ARG2 REVERSED arg2 = cons(arg1, nil) %while arg3 # nil %cycle arg2 = cons(hd(arg3), arg2) arg3 = tl(arg3) %repeat stack(arg2) %return %end ! END LASTPUT ! ! %integer %fn equal(%integer list1, list2) %if quitflag = 1 %then %start quitflag = 0 jumpout = 0 jumpflag = 1 %result = quit %finish %if holdflag = 1 %then %start holdflag = 0 stksys(list1) stksys(list2) error("USER INTERRUPT", empty, 0, in) list2 = unstksys list1 = unstksys %if jumpflag = 1 %then %result = unstack %finish %if list1 = list2 %then %result = true ! WORD %if list1 & lm = 0 %or list2 & lm = 0 %or list1 = nil %C %or list2 = nil %then %result = false %if equal(hd(list1), hd(list2)) = true %then %C %result = equal(tl(list1), tl(list2)) %result = false %end ! END EQUAL ! ! ! FILING SYSTEM SUPPORT ROUTINES %routine restfile ! RESTORES OWNER ETC. owner = wstr2 userfile = wstr1 mdp = w1 mdind = w2 %unless cactfile = 2 %then getmaster %end ! END RESTFILE ! %routine savefile ! SAVES OWNER, USERFILE, MDP, MDIND DURING LIBRARY AND BORROWFILE wstr2 = owner owner = wstr1 wstr1 = userfile w1 = mdp w2 = mdind %end ! END SAVEFILE ! %routine nofile cactfile = 0 userfile = "" owner = emasuser mdp = 0 mdind = 0 %end ! END NOFILE ! %routine frothdir ! FREES ANOTHERS FILE closesm(4) clear("4") disconnect(owner . "." . masfile) %end ! END FROTHDIR ! %routine sharefile(%string (15) filename) ! CONNECTS A FILE FOR SHARED READ ! EXITS IF CURRENTLY CONNECTED WRITE ELSEWHERE %integer stat stat = status(filename, 0) %if stat < 0 %or (stat # 0 %and stat & 4 = 0) %then %start %if sw = 86 %then restfile %if sw = 85 %then nofile %and getmaster %finish %else %return %if stat < 0 %C %then error("FINFO CALL FAILS - ", (-stat) << 8 ! nm, 1, in) %C %else error("LIBRARY IS BEING UPDATED - TRY AGAIN", empty, %C 1, in) %end ! END SHAREFILE ! %integer %fn findfile %integer i mdp = 0 udp = 0 txtp = 0 ff1: mdmap(filstart + mdp * 4096) %unless mdents = 0 %then %start i = 1 %while i <= mdents %cycle %if quitflag = 1 %then %start quitflag = 0 jumpout = 0 jumpflag = 1 %if sw = 75 %then nofile %else frothdir %if sw = 86 %then restfile %if sw = 85 %then nofile %and getmaster %result = quit %finish %if holdflag = 1 %then %start holdflag = 0 %if sw = 75 %then nofile %else frothdir %if sw = 86 %then restfile %if sw = 85 %then nofile %and getmaster error("USER INTERRUPT - PROCESS ABANDONNED", empty, 1, %C in) %result = unstack %finish %if i = 63 %then mdp = mdnext %and -> ff1 %if udnam(i) = userfile %then %result = i i = i + 1 %repeat %finish %result = -1 %end !END FINDFILE ! %routine gothdir ! CONNECTS ANOTHERS MASTER FILE ! OWNER CONTAINS OWNERS NAME %integer temp sharefile(owner . "." . masfile) %if jumpflag = 1 %then %return define("4," . owner . "." . masfile) filstart = smaddr(4, flen) temp = findfile %if jumpflag = 1 %then stack(temp) %and %return %if temp < 0 %then %start frothdir %if sw = 86 %then restfile %if sw = 85 %then nofile %and getmaster error("CANNOT FIND LIBRARY FILE ", empty, 1, in) %return %finish mdind = temp %end ! END GOTHDIR ! %routine claimmaster ! CLAIMS MASTER FILE FOR WRITE %integer stat stat = status(masfile, 0) %if stat = 0 %then permit(maswrite) %else %start %if sw = 75 %then nofile %if sw = 104 %or sw = 105 %then device = tty %unless cactfile = 2 %then getmaster %if stat < 0 %C %then error("FINFO CALL FAILS - ", (-stat) << 8 ! nm, 1, %C in) %C %else error("YOUR FILE IS IN USE BY ANOTHER - TRY AGAIN", %C empty, 1, in) %return %finish getmaster %end ! END CLAIMMASTER ! %routine filetidy %string (10) size %integer tlen, page, tmdp, ttxtp, tindex, i, j, k %unless cactfile = 2 %then cluserfl claimmaster %if jumpflag = 1 %then %return mdmap(filstart) %if mdents = 0 %then %start closesm(4) permit(masread) %return %finish tmdp = 0 page = 0 txtp = 0 size = numtostr(flen << 8) define("10,T#JUNK") newsmfile("T#JUNK," . size) tstart = smaddr(10, tlen) tmdmap(tstart) tendmap tendtxt = 0 tmdents = 0 ft1: i = 1 %while i <= mdents %cycle %if i = 63 %then mdmap(filstart + mdnext * 4096) %and -> ft1 %unless udnam(i) = "" %then %start tmdents = tmdents + 1 %if tmdents = 63 %then %start page = page + 1 tmdnext = page tmdp = page tmdmap(tstart + page * 4096) tmdents = 1 %finish tudnam(tmdents) = udnam(i) %if cactfile = 1 %then %start %if udnam(i) = userfile %then mdp = tmdp %C %and mdind = tmdents %finish page = page + 1 tudpage(tmdents) = page tudmap(tstart + page * 4096) tudents = 0 udmap(filstart + udpage(i) * 4096) ft2: j = 1 %while j <= udents %cycle %if j = 61 %then udmap(filstart + udnext * 4096) %C %and -> ft2 %unless funnam(j) = "" %then %start tudents = tudents + 1 %if tudents = 61 %then %start page = page + 1 tudnext = page tudmap(tstart + page * 4096) tudents = 1 %finish tfunnam(tudents) = funnam(j) %if tendtxt = 0 %or shortint(tendind(1)) = 4093 %then %C %start page = page + 1 ttxtp = page %unless tendtxt = 0 %then ttxtnext = page ttxtmap(tstart + page * 4096) tindex = 0 ttxtnext = 0 tendtxt = page tendind(1) = 0 tendind(2) = 1 %finish %if txtp # txtpage(j) %then gettxtp(j) index = shortint(txtind(1, j)) ft3: %if tindex = 4092 %then %start page = page + 1 ttxtnext = page ttxtp = page setshortint(ttxtents(1), 4092) ttxtmap(tstart + page * 4096) tindex = 0 ttxtnext = 0 %finish tindex = tindex + 1 readinsym(k) tfntxt(tindex) = k %if k = termin %then %start %if index <= shortint(txtents(1)) %or txtnext # 0 %C %then %start %if nextinsym # 'T' %then -> ft3 %finish %finish %else -> ft3 ttxtpage(tudents) = tendtxt ttxtind(1, tudents) = tendind(1) ttxtind(2, tudents) = tendind(2) tendtxt = ttxtp setshortint(tendind(1), tindex + 1) setshortint(ttxtents(1), tindex) %finish j = j + 1 %repeat %finish i = i + 1 %repeat closesm(4) clear("4") destroy(masfile) %if page * 4096 + 4096 < tlen %then %start size = numtostr((page * 4096 + 4096) << 8) define("4," . masfile) newsmfile(masfile . "," . size) filstart = smaddr(4, flen) %cycle i = 0, 4096, flen - 4096 j = filstart + i k = tstart + i move(4096, k, j) %repeat closesm(10) destroy("T#JUNK") closesm(4) %finish %else %start closesm(10) rename("T#JUNK," . masfile) %finish clear("10") cherish(masfile) permit(masread) permit(masfile . ",,R") %end ! END FILETIDY ! %routine updir(%integer name) %integer i udp = udpage(mdind) up1: udmap(filstart + udp * 4096) i = 1 %if udents = 0 %then -> up2 %while i <= udents %cycle %if i = 61 %then udp = udnext %and -> up1 %if wa(name >> 8) = funnam(i) %then %start txtpage(i) = endtxt txtind(1, i) = endind(1) txtind(2, i) = endind(2) setshortint(endind(1), index) endtxt = txtp %return %finish i = i + 1 %repeat %if udents = 60 %then getpage(2) up2: udents = udents + 1 funnam(udents) = wa(name >> 8) txtpage(udents) = endtxt txtind(1, udents) = endind(1) txtind(2, udents) = endind(2) setshortint(endind(1), index) endtxt = txtp %end ! END UPDIR ! %integer %fn fnents %integer no mdmap(filstart + mdp * 4096) endmap getudp txtp = 0 no = udents %while udents = 61 %cycle udp = udnext udmap(filstart + udp * 4096) no = no - 1 + udents %repeat %result = no %end !END FNENTS ! ! %routine chlib !CHECKS LIBRARY OWNER arg1 = unstack arg2 = unstack %if arg1 & wm # wm %then %start error(" INVALID NAME FOR LIBRARY OWNER - ", arg1, 1, in) %return %finish wstr1 = wa(arg1 >> 8) ! GET CHARS %if length(wstr1) # 6 %then %start error("INVALID NAME FOR LIBRARY OWNER - ", arg1, 1, in) %return %finish %cycle w1 = 1, 1, 4 wstr2 = fromstring(wstr1, w1, w1) %if wstr2 <= "9" %then %start ! NUMERIC CHAR error("INVALID NAME FOR LIBRARY OWNER - ", arg1, 1, in) %return %finish %repeat %cycle w1 = 5, 1, 6 wstr2 = fromstring(wstr1, w1, w1) %if wstr2 > "9" %then %start ! NON NUMERIC CHAR error("INVALID NAME FOR LIBRARY OWNER - ", arg1, 1, in) %return %finish %repeat %if arg2 & wm # wm %C %then error("LIBRARY NAME MUST BE A WORD - ", arg2, 1, in) %end !END CHLIB ! ! ! ! TURTLE DEVICE SERVICE ROUTINES ! %routine %spec tsend(%integer motors, pulses) %routine %spec tsend1(%integer arg) %integer %fn %spec tscale(%integer n) %integer %fn %spec tangle(%integer n) ! %integer %fn intrem(%integer i, j) %result = i - (i // j) * j %end ! END INTREM ! %integer %fn mod360(%integer i) i = intrem(i, 360) %if i < 0 %then %result = i + 360 %else %result = i %end ! END MOD360 ! %routine coordok(%integer coord) %string (80) errm %if coord < (-501) %or coord > 501 %then %start errm = "THE TURTLE WILL GO OFF THE EDGE OF THE " %if tdev = 3 %or tdev = 8 %then errm = errm . "SCREEN" %C %else errm = errm . "PAPER" error(errm, empty, 1, in) %finish %end ! END COORDOK ! %integer %fn tstate %result = cons(intpt(xturtle) << 8 ! nm, %C cons(intpt(yturtle) << 8 ! nm, cons(hdturtle << 8 ! nm, %C cons(penturtle, nil)))) %end ! END TSTATE ! %integer %fn impnum(%integer i) %if i < 0 %then %result = i >> 8 ! t8 %else %result = i >> 8 %end ! END IMPNUM ! %routine circletest(%integer flag, rad, ang) %switch sw(0:1) coordok(intpt(xturtle + dx)) %if jumpflag = 1 %then %return coordok(intpt(yturtle + dy)) %if jumpflag = 1 %then %return %if rad < 0 %then rad = -rad %if ang < 0 %then ang = -ang -> sw(flag) sw(0): !LEFT %if ang >= mod360(360 - hdturtle) %then %start coordok((yc // 32) + intpt(yturtle) - rad) %if jumpflag = 1 %then %return %finish %if ang >= mod360(270 - hdturtle) %then %start coordok((xc // 32) + intpt(xturtle) - rad) %if jumpflag = 1 %then %return %finish %if ang >= mod360(180 - hdturtle) %then %start coordok((yc // 32) + intpt(yturtle) + rad) %if jumpflag = 1 %then %return %finish %if ang >= mod360(90 - hdturtle) %then %start coordok((xc // 32) + intpt(xturtle) + rad) %if jumpflag = 1 %then %return %finish %return ! sw(1): !RIGHT %if ang >= hdturtle %then %start coordok((yc // 32) + intpt(yturtle) + rad) %if jumpflag = 1 %then %return %finish %if ang >= mod360(hdturtle + 90) %then %start coordok((xc // 32) + intpt(xturtle) + rad) %if jumpflag = 1 %then %return %finish %if ang >= mod360(hdturtle + 180) %then %start coordok((yc // 32) + intpt(yturtle) - rad) %if jumpflag = 1 %then %return %finish %if ang >= mod360(hdturtle + 270) %then %start coordok((xc // 32) + intpt(xturtle) - rad) %if jumpflag = 1 %then %return %finish %return %end ! END CIRCLETEST ! %integer %fn chdevarg %integer arg arg = unstack %if arg & nm = 0 %then %start error(wa(fn >> 8) . " MUST HAVE A NUMBER AS INPUT - ", arg, %C 1, in) %result = unstack %finish w1 = arg %result = impnum(arg) %end ! END CHDEVARG ! %routine setup(%integer n, a) %integer h %if n = 0 %then %return h = 0 %if a > 180 %then a = a - 360 %if penturtle = down %then %start penturtle = up tsend1(32) h = 1 %finish %if a # 0 %then %start %if a < 0 %then tsend(ltbits, tangle(-a)) %C %else tsend(rtbits, tangle(a)) %if jumpflag = 1 %then %return ! RIGHT (A) %finish %if n < 0 %then tsend(bdbits, tscale(-n)) %C %else tsend(fdbits, tscale(n)) %if jumpflag = 1 %then %return ! FORWARD(N) %if a # 0 %then %start %if a < 0 %then tsend(rtbits, tangle(-a)) %C %else tsend(ltbits, tangle(a)) %if jumpflag = 1 %then %return ! LEFT(A) %finish %if h = 1 %then %start penturtle = down tsend1(32) %finish %end ! END SETUP ! %routine tsend1(%integer arg) %if arg = 0 %then %return %if penturtle = up %then binarg(1, arg + penbit) %C %else binarg(1, arg) ! JAM TRANSFER ONLY REQUIREDD FOR HOOTBIT sendbin(0, 1) %end ! END TSEND1 ! %routine tsend(%integer motors, pulses) %while pulses > 1500 %cycle ! 500 MOVE UNITS OR 375 ROTATE UNITS %if quitflag = 1 %then %start quitflag = 0 jumpout = 0 jumpflag = 1 cleset ! THIS IS THE POINT OF IT. TO BREAK A CLOG IN H316 stack(quit) %return %finish %if holdflag = 1 %then %start holdflag = 0 cleset error("USER INTERRUPT - TURTLE DEVICE RESET", empty, 1, in) %return %finish tsend1(motors + 1500) pulses = pulses - 1500 %repeat tsend1(motors + pulses) %end ! END TSEND ! %routine pindsend(%integer direction, angle) ! SENDS FOR PLOTTER INDICATOR binarg(1, 5) %while angle > 360 %cycle %if quitflag = 1 %then %start ! AS FOR TSEND quitflag = 0 jumpout = 0 jumpflag = 1 cleset stack(quit) %return %finish %if holdflag = 1 %then %start holdflag = 0 cleset error("USER INTERRUPT - TURTLE DEVICE RESET", empty, 1, in) %return %finish binarg(2, 360 + direction) sendbin(0, 2) angle = angle - 360 %repeat binarg(2, angle + direction) sendbin(0, 2) %end ! END PINDSEND ! %integer %fn 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 ! %integer %fn 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 %then %return %if m = 0 %then %start hdturtle = hdturtle - a %finish %else %start hdturtle = hdturtle + a %finish calcturtle %end ! END ARCAUX ! c = -1 d = 0 th = 2 %if a < 0 %then %start hdturtle = mod360(hdturtle - 180) calcturtle r = -r a = -a %finish %if r < 0 %then %start 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 %or (n - rv1) > 0.1 %C %or (n - rv1) < (-0.1)) %then %start 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 %then %start 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 %then %return %if m = 0 %then %start tsend(rtbits, a) %if jumpflag = 1 %then %return tthead = tthead - a %finish %else %start tsend(ltbits, a) %if jumpflag = 1 %then %return 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 %then %start hdturtle = mod360(hdturtle - 180) tsend(rtbits, 720) ! RIGHT(180) %if jumpflag = 1 %then %return r = -r a = -a %finish tthead = 4 * hdturtle %if r < 0 %then %start 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 %or (n - rv1) > 0.1 %C %or (n - rv1) < (-0.1)) %then %start th = th + 1 -> loop %finish p = a // th q = intrem(a, th) e = intpt(th / 2.0) arcaux(c, e) %if jumpflag = 1 %then %return %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 %then %return arcaux(c, th) %if jumpflag = 1 %then %return p = p - 1 %if p = 0 %and q # 0 %then %start 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 %then %return xturtle = tttxcor / 3.0 yturtle = tttycor / 3.0 hdturtle = mod360(int(tthead / 4.0)) %end ! END TARCLEFT ! %routine claimdevice(%integer n) %record (rf) r %integer flag %if tdev # 0 %then %start ! ALREADY GOR A DEVICE %if tdev = n %then error("YOU ALREADY HAVE IT", empty, 1, in) %C %else error("YOU CAN ONLY BE CONNECTED TO ONE DEVICE", %C empty, 1, in) %return %finish ! SO NOT GOT A DEVICE connect(masnum . tdevnames(n), 2, 0, 0, r, flag) ! CONNECT WRITE, NO SHARING - SO WE GOT IT ALONE %if flag # 0 %C %then error("DEVICE " . tdevnames(n) . " IS ALREADY CONNECTED ELSEWHERE", empty, 1, in) %and %return ! FLAG#0 INDICATES CONNECTING NOT POSSIBLE, I.E. DEVICE IN USE ! ! SO NOW GOT DEVICE tdev = n prstring(tdevnames(n) . " CONNECTED") nooline(1) %end ! END CLAIMDEVOCE ! %routine freedevice ! ONLY IF TDEV#0 cleset %unless tdev = 8 ! CLEAR AND RESET HONEY AS APROPRIATE disconnect(masnum . tdevnames(tdev)) tdev = 0 %end ! END FREEDEVICE ! %routine gcompile(%real x, y, %integer mode) !COMPILES A VECTOR DEFINITION INTO GT42 CODE %extrinsic %integer %array modetable(0 : 2) ! %integer penv %if penturtle = down %then penv = pen %else penv = 0 %if mode # gmode %then curpic = consg(modetable(mode), curpic) %C %and gmode = mode curpic = consg((conv(int(y))), consg(penv ! (conv(int(x))), %C curpic)) %end ! %integer %fn getnumb(%integer %name 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 %C %then error(func . " NEEDS A LONGER LIST ", arg2, 1, in) %and %C %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, %C in) %C %and %result = -100000 !CHECK THAT YOU HAVE A NUMBER %result = w1 >> 8 !AND RETURN ITS VALUE %end %integer %fn checkxy(%integer n) ! ! CHECKS THAT GIVEN COORDINATE IS WITHIN THE SCREEN ! BOUNDARY (-512 -> 512) ! %while n > 512 %cycle n = n - 1024 %repeat %while n < -512 %cycle n = n + 1024 %repeat %result = n %end ! ! %routine vector(%real x, y) %integer t %if defpicture = 1 %then gcompile(x, y, vectorm) %and %return %if penturtle = down %and showturtle42 = 1 %then %start t = intpt(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 %C %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 savegp %if defpicture = 1 %then gcompile(atx, aty, pointm) savegp = graphp vecorpoint(int(atx), int(aty), 0, pointm) graphp = savegp %end ! ! %routine modifyexec ! !*** "HACK" DP1 EXEC FOR LOGO USE !*** TO GIVE IMPROVED STATIC/DYNAMIC PICTURE !*** CAPABILITIES ! %const %integer %array newheader(1 : 15) = %C X'E000', X'3FF0', X'F700', X'0000', %C X'2028', X'2028', X'8F5C', X'404A', X'4F8A', X'6F8A', %C X'404A', X'E000', X'2012', X'E000', X'201A' %const %integer %array newtail(1 : 5) = X'9354', 512, %C 512, X'E000', X'2028' %const %integer ref1 = X'1016' %const %integer ref2 = X'145E' %const %integer staddr = X'200E' %integer i ! set42(chpic) graphp = initgraphp lbr ch3(setn) ch3(staddr) ch3(15) %cycle i = 1, 1, 15 ch3(newheader(i)) %repeat ch3(setn) ch3(corebottom) ch3(5) %cycle i = 1, 1, 5 ch3(newtail(i)) %repeat ch3(set) ch3(ref1) ch3(turtlestart) !**IMPORTANT** MOD TO "CLEAR" !INSTRINGT42EXEC ch3(set) ch3(ref2) ch3(turtlestart) rbr %end ! ! %routine calcturtle %integer i ! ! THIS ROUTINE SENDS A VECTOR DESCRIPTION OF THE ! TURTLE TO THE GT42 - ASSUMING THAT THE TURTLE ! IS CURRENTLY BEING SHOWN ! %integer %fn vec(%integer dx, dy) !CONVERTS DX,DY INTO A GT42 SHORT VECTOR ! %if dx < 0 %then dx = X'40' + ((0 - dx) & X'3F') %C %else dx = dx & X'3F' %if dy < 0 %then dy = X'40' + ((0 - dy) & X'3F') %C %else dy = dy & X'3F' %result = X'4000' ! (dx << 7) ! dy %end %const %integer %array x(1 : 4) = 0, 31, -31, 0 %const %integer %array y(1 : 4) = -10, 10, 10, -10 !*** FUNCTIONS TO CALCULATE NEW X AND Y DISPLACEMENTS *** !*** (DONE LIKE THIS FOR EASE OF MODIFICATION ) *** %integer %fn newx %result = int(x(i) * cos(hdturtle / 57.3) - sin(hdturtle / 57.3) * y(i)) %end %integer %fn newy %result = int(y(i) * cos(hdturtle / 57.3) + x(i) * sin(hdturtle / 57.3)) %end %const %integer turtlemode = X'8F5C' %return %if showturtle42 = 0 %return %if defpicture = 1 ! DON"T BOTHER WITH TURTLE IN DEF MODE set42(chpic) lbr ch3(setn) ch3(turtlestart) ch3(5) ch3(turtlemode) ! 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 showturtle showturtle42 = 1 calcturtle %end %routine hideturtle ! ! *** 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(turtlestart) ch3(2) ch3(djump) ! JUMP INSTRUCTION ch3(dlast) ! TO END OF DISPLAY FILE rbr showturtle42 = 0 %end ! %routine setcorepointer(%integer toval) ! USED TO ASSIGN TO END OF CORE POINTER IN GT42 ! ! ALSO UPDATES EMAS LOCAL VARIABLE PICTURE POINTER ! %const %integer corepointer = X'2010' ! ADDRESS IN GT42 ! picturepointer = toval ! UPDATE EMAS POINTER set42(chpic) ch3(set) ! AND GT42 POINTER ch3(corepointer) ch3(picturepointer) ! NEW VALUE %end %routine inc(%integer w1) ! *** ROUTINE TO SEND A PICTURE DEFINITION ! *** TO THE GT42 -- CALLED FROM "INCLUDE" AND "PUT" ! %integer w2, w3 set42(chpic) ! SET GT42 MODE w2 = listlen(index42(w1)_ptr) ! LENGTH OF PICTURE index42(w1)_faddr = picturepointer picturepointer = picturepointer - w2 - w2 - 2 lbr ch3(setn) ch3(picturepointer) ch3(w2) !HEADER!! w3 = consg(djump, consg(index42(w1)_faddr, %C tl(tl(index42(w1)_ptr)))) %until w3 = nil %cycle ch3(hd(w3) >> 8) w3 = tl(w3) %repeat rbr ! DELIMITER index42(w1)_ptr42 = picturepointer ! START ADDR IN 42 setcorepointer(picturepointer) %if picturepointer < graphp %C %then error("GT42 DISPLAY FILE CORRUPTED :-" . snl . %C "TOO MUCH DISPLAY DATA", empty, 1, in) %and %return %end ! ! ! ! INFERENCE SERVICE ROUTINES ! %routine sayl(%string (20) mess, %integer rule, indent) ! PRINTS MESS INDENTED INDENT SPACES %if getval(thinkaloud, envir) = true %then %start printstring("*") spaces(indent) charout = charout + 1 + indent prstring(mess) printel(rule) nooline(1) %finish %end ! END SAYL ! %integer %fn fitsq(%integer fact, pat) ! MATCHES FACT AGAINST PAT. ! FACT AND PAT ARE ASSUMED TO BE SIMPLE PATTERNS. ! (FACT WILL HAVE HAD COLON VARIABLES ASSIGNED ALREADY.) %integer val %if fact = nil %then %start %if pat = nil %then %result = true %result = false %finish %if pat = nil %then %result = false ! (NEXT LINE INCORRECT IF FACT ALLOWED TO CONTAIN QUOTED VARIABLES.) %if hd(pat) = quote %then setval(hd(tl(pat)), hd(fact), envir) %C %else %start %if hd(pat) = dots %then %start val = getval(hd(tl(pat)), envir) %if val = undef %then %start error("NO VALUE HAS BEEN GIVEN TO VARIABLE -", %C hd(tl(pat)), 1, in) %result = unstack %finish %if val # hd(fact) %then %result = false %finish %else %start %if hd(pat) # hd(fact) %then %result = false %result = fitsq(tl(fact), tl(pat)) %finish %finish %result = fitsq(tl(fact), tl(tl(pat))) %end ! END FITSQ ! %routine setvbls(%integer vbls) ! VBLS IS A LIST OF QUOTED VARIABLES. EACH VARIABLE IS SET TO NIL, ! EITHER GLOBALLY OR LOCALLY. %integer i, l vbls = hd(tl(vbls)) l = listlen(vbls) %if envir = basenvir %then %start %cycle i = 1, 1, l setval(hd(vbls), nil, envir) vbls = tl(vbls) %repeat %finish %else %start %cycle i = 1, 1, l stack(nil) %repeat envir = setbind(vbls, envir) %finish %end ! END SETVBLS ! %routine tryimprule(%integer rule, fact, keyed, indent) ! MATCHES IMPLIED RULE AGAINST FACT. ! KEYED IS TRUE IF RULE STARTS WITH AKEYWORD, FALSE IF IT STARTS WITH ! A QUOTED WORD. IF MATCH IS FOUND, ADDS IMPLIED FACT. %integer vbls, pred vbls = hd(rule) rule = tl(rule) %if vbls # nil %then setvbls(vbls) %if keyed = true %then pred = fitsq(tl(fact), tl(hd(rule))) %C %else pred = fitsq(fact, hd(rule)) %if jumpflag = 1 %then stack(pred) %and %return %if pred = true %then %start sayl("USING RULE ", cons(implies, rule), indent) addfact(hd(tl(rule)), indent + 3) %finish %end ! END TRYIMPRULE ! %integer %fn vblsin(%integer terms) ! LOOKS FOR QUOTED VARIABLES IN IMPLY/TOINFER RULE, TERMS, AND PUTS ! THEM INTO A LIST CONSED ON TO "NEW". E.G. [NEW [X Y]] ! CHECKS THAT CONSEQUENT OF TOINFER RULE DOESN"T CONTAIN A DOTTED ! VARIABLE AND THAT AN IMPLY RULE ONLY HAS ONE CONSEQUENT. %integer term, vbls, rule, first vbls = nil rule = hd(terms) terms = tl(terms) first = true %while terms # nil %cycle term = hd(terms) %if term & lm # lm %or term = nil %then -> vblerr %if hd(term) & lm = lm %then -> vblerr %while term # nil %cycle %if quitflag = 1 %then %start quitflag = 0 jumpflag = 1 jumpout = 0 %result = quit %finish %if holdflag = 1 %then %start 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 %then %start term = tl(term) %if term = nil %or hd(term) & wm # wm %then -> vblerr vbls = cons(hd(term), vbls) %finish %else %start %if hd(term) = dots %then %start %if rule = toinfer %and first = true %then -> vblerr term = tl(term) %if term = nil %or hd(term) & wm # wm %then -> vblerr %finish %finish term = tl(term) %repeat terms = tl(terms) %if first = false %then %start %if terms # nil %and rule = implies %then -> vblerr %finish %else 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 ! %integer %fn instance(%integer item) ! ITEM IS A (SIMPLE?) PATTERN. ! IF IT IS SIMPLE,CHECKS THAT IT IS IN CORRECT FROM AND ASSIGNS ! CURRENT VALUES TO COLON VARIABLES. %integer val %if item = nil %then %result = nil %if quitflag = 1 %then %start quitflag = 0 jumpflag = 1 jumpout = 0 %result = quit %finish %if holdflag = 1 %then %start 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 %then %start item = tl(item) %if item = nil %or hd(item) & wm # wm %then -> insterr val = getval(hd(item), envir) %if val = undef %C %then error("NO VALUE HAS BEEN GIVEN TO VARIABLE - ", %C hd(item), 1, in) %and %result = unstack %finish %else %start %if val = quote %then %start %if tl(item) = nil %or hd(tl(item)) & wm # wm %C %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, %integer %array %name links) ! ADDS PATTERN, ITEM, TO ONE OF DATABASE,IMPRULES OR INFRULES ! ACCORDING TO VALUE OF LINKS. SETS UP WORD, KEY, AS AN ! ASSOCIATION SET, IF IT DOES NOT ALREADY EXIST, ADDING KEY TO ONE OF ! FACTKEYS, IMPKEYS, INFKEYS, AND ADDS ITEM TO THE ASSOCIATION SET. %integer val, ind %if key & wm # wm %then %start %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 %then %start val = tl(hd(val)) rephead(val, cons(item, hd(val))) %finish %else %start bvalue(links(3) >> 8) = cons(key, bvalue(links(3) >> 8)) assocwa(ind) = cons(cons(links(2), cons(cons(item, nil), %C nil)), assocwa(ind)) %finish %end ! END ADDLINK ! %routine addrule(%integer rule, indent, %integer %array %name links) ! REPLACES HEAD OF RULE WITH A LIST OF THE QUOTED VARIABLES IN THE RULE ! OF THE FORM [NEW [X Y]]. ADDS THE RULE TO IMPRULES/INFRULES. %integer vbls %if tl(rule) = nil %then %start error("INVALID PATTERN FOR IMPLIES/TOINFER RULE -", tl(rule), %C 1, in) %return %finish stksys(rule) vbls = vblsin(rule) rule = unstksys %if jumpflag = 1 %then stack(vbls) %and %return vbls = cons(vbls, tl(rule)) addlink(vbls, hd(hd(tl(rule))), links) %if jumpflag = 1 %then %return sayl("ADDED RULE ", rule, indent) %end ! END ADDRULE ! %routine addfact(%integer fact, indent) ! ADDS A FACT TO DATABASE.(NO CHECK MADE FOR FACT CONTAINING QUOTED ! VARIABLES.) CHECKS IF KEYWORD POINTS TO ANY IMPLIED RULES, I.E. IF ! THE ASSOCIATION SET, KEY, HAS ANY VALUES WITH ATTRIBUTE "IMPLIES", ! AND, IF THEY MATCH FACT, ADDS THE IMPLIED FACT. ! SIMILARLY, CHECKS IF FACT MATCHES ANY IMPLIED RULES WHOSE KEY WORD IS ! NOT FIRST, BY LOOKING AT THE ASSOCIATION SET FOR "QUOTE", AND ADDS ! ANY MATCHING IMPLIED FACT. %integer key, val fact = instance(fact) %if jumpflag = 1 %then stack(fact) %and %return key = hd(fact) addlink(fact, key, dbase) %if jumpflag = 1 %then %return sayl("ADDED FACT ", fact, indent) val = findass(assocwa(key >> 8), implies) %if val # nil %then %start val = hd(tl(hd(val))) %while val # nil %cycle %if quitflag = 1 %then %start quitflag = 0 jumpflag = 1 jumpout = 0 stack(quit) %return %finish %if holdflag = 1 %then %start 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 %then %return val = tl(val) %repeat %finish val = findass(assocwa(quote >> 8), implies) %if val # nil %then %start val = hd(tl(hd(val))) %while val # nil %cycle %if quitflag = 1 %then %start quitflag = 0 jumpflag = 1 jumpout = 0 stack(quit) %return %finish %if holdflag = 1 %then %start 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 %then %return val = tl(val) %repeat %finish %end ! END ADDFACT ! %integer %fn trybest(%integer %array %name links, %integer %C %name epat, keyed, %integer ipat) ! IPAT IS A PATTERN (SHOULD BE SIMPLE). ! IF ITS HEAD IS A QUOTED VARIABLE, RETURNS ONE OF DATABASE, IMPRULES ! OR INFRULES, DEPNEDING ON VALUE OF LINKS, AND SETS KEYED TO FALSE, ! EPAT TO IPAT. OTHERWISE, RETURNS THE ASSOCIATION SET FOR HD(IPAT) ! WITH ATTRIBUTE FACT, IMPLIES OR TOINFER AND SETS KEYED TO TRUE, ! EPAT TO TL(IPAT). %integer it %if hd(ipat) = quote %then %start epat = ipat keyed = false %result = bvalue(links(1) >> 8) %finish keyed = true %if hd(ipat) = dots %then %start epat = tl(tl(ipat)) it = getval(hd(tl(ipat)), envir) %if it = undef %then %start error("NO VALUE HAS BEEN GIVEN TO VARIABLE - ", %C hd(tl(ipat)), 1, in) %result = unstack %finish %finish %else %start epat = tl(ipat) it = hd(ipat) %finish %if it & wm # wm %then %start 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 ! %integer %fn infinstance(%integer term) ! TERM IS AN ANTECEDENT OF A TOINFER RULE. ! RETURNS TERM WITH COLON VARIABLES REPLACED BY THEIR CURRENT ! VALUES (THIS MAY BE A QUOTED VARIABLE OR ANOTHER COLON VARIABLE) ! AND QUOTED VARIABLES ASSIGNED TO LOCAL COLON VARIABLES AND REPLACED ! BY LOCAL QUOTED VARIABLES. (SO THEY DO NOT CLASH WITH QUOTED ! VARIABLES OF ORIGINAL PATTERN WHICH WAS MATCHED AGAINST CONSEQUENT OF ! THIS TOINFER RULE.) %integer vf, it %string (10) str1, str2 %if term = nil %then %result = nil %if quitflag = 1 %then %start quitflag = 0 jumpflag = 1 jumpout = 0 %result = quit %finish %if holdflag = 1 %then %start 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 %then %start vf = getval(hd(tl(term)), envir) %if vf = undef %then %start error("NO VALUE HAS BEEN GIVEN TO VARIABLE - ", %C hd(tl(term)), 1, in) %result = unstack %finish %if vf & lm # lm %or vf = nil %then %C %result = cons(vf, infinstance(tl(tl(term)))) %if hd(vf) = quote %then %start rephead(vf, dots) %result = cons(quote, cons(hd(tl(vf)), %C infinstance(tl(tl(term))))) %finish %if hd(vf) # dots %then %C %result = cons(vf, infinstance(tl(tl(term)))) %result = cons(dots, cons(hd(tl(vf)), %C infinstance(tl(tl(term))))) %finish %if hd(term) # quote %then %C %result = cons(hd(term), infinstance(tl(term))) genos = genos + 1 str1 = wa(vbl >> 8) str2 = numtostr(genos << 8) it = put(str1 . str2) setval(hd(tl(term)), cons(dots, cons(it, nil)), envir) %result = cons(quote, cons(it, infinstance(tl(tl(term))))) %end ! END INFINSTANCE ! %integer %fn inffitsq(%integer pat, rpat) ! MATCHES PATTERN, PAT, AGAINST CONSEQUENT OF TOINFER RULE, RPAT. ! SETS QUOTED VARIABLES IN RPAT TO CORRESPONDING VALUE IN PAT ! (THIS MAY ALSO BE A QUOTED VARIABLE). SETS ANY OTHER QUOTED ! VARIABLES IN PAT TO CORRESPONDING VALUE IN RPAT. %integer p1, rp1 inff1: %if pat = nil %then %start %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 %then %start p1 = getval(hd(pat), envir) %if p1 = undef %then %start error("NO VALUE HAS BEEN GIVEN TO VARIABLE - ", hd(pat), %C 1, in) %result = unstack %finish pat = tl(pat) %finish %else %start %if p1 = quote %then %start p1 = hd(pat) pat = tl(pat) %if rp1 = quote %then %start setval(hd(rpat), cons(quote, cons(p1, nil)), envir) rpat = tl(rpat) %finish %else setval(p1, rp1, envir) -> inff1 %finish %finish %if rp1 = quote %then %start setval(hd(rpat), p1, envir) rpat = tl(rpat) -> inff1 %finish %if p1 = rp1 %then -> inff1 %result = false %end ! END INFFITSQ ! %integer %fn tryinfrule(%integer rule, epat, pat, keyed, indent) ! MATCHES PATTERN, EPAT, AGAINST TOINFER RULE, RULE. ! IF EPAT MATCHES CONSEQUENT OF TOINFER RULE, SUBSTITUTES ! CURRENT VALUES FOR VARIABLES IN ANTECEDENT(S) AND TRIES ! TO MATCH ANTECEDENT(S) USING TRYINFQ. %integer vbls, pred, list, savlist, temp vbls = hd(rule) rule = tl(rule) %if vbls # nil %then setvbls(vbls) %if keyed = true %then pred = inffitsq(epat, tl(hd(rule))) %C %else pred = inffitsq(epat, hd(rule)) %if jumpflag = 1 %then %result = pred %if pred = true %then %start 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 ! %integer %fn bindings(%integer vlist) ! VLIST IS THE LIST OF VARIABLES OF FINDANY/FINDALL. ! A LIST OF THE VALUES OF THESE VARIABLES IS RETURNED. %integer val %if vlist = nil %then %result = nil val = getval(hd(vlist), envir) %if val = undef %then %start error("NO VALUE HAS BEEN GIVEN TO VARIABLE - ", hd(vlist), 1, %C in) %result = unstack %finish %result = cons(val, bindings(tl(vlist))) %end ! END BINDINGS ! %integer %fn tryinfq(%integer pat, indent) ! MATCHES PATTERN, PAT. ! IF PAT HAS A KEYWORD, MATCHES AGAINST ITS ASSOCIATION SET, ! FIRSTLY WITH ATTRIBUTE "FACT", THEN "TOINFER", ! EXITING IF A MATCH IS FOUND AND ONLY ONE MATCH REQUIRED (VALUE ! OF SW DETERMINES THIS). OTHERWISE, PAT IS MATCHED AGAINST ! DATABASE, THEN INFRULES, EXITING AS ABOVE. FINALLY, IF PAT HAS ! A KEYWORD, IT IS MATCHED AGAINST THE ASSOCIATION SET FOR "QUOTE" ! WITH ATTRIBUTE "TOINFER", EXITING AS ABOVE. ! BEFORE EXITING, IF CURRENT FUNCTION IS FINDALL, ASSIGNS CURRENT ! VALUES TO ITS VARIABLE LIST, AND CONS"S THIS LIST TO ARG3 AS RESULT. %integer ipat, epat, keyed, it, fact, res, temp %if pat = nil %then %start %if sw = 156 %then %start 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 %then %start quitflag = 0 jumpflag = 1 jumpout = 0 %result = quit %finish %if holdflag = 1 %then %start 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 %then %start it = tl(it) %if it = nil %then -> tryinferr %finish it = tl(it) %repeat sayl("LOOK FOR ", ipat, indent) %if hd(ipat) = not %then %start %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 %then %start quitflag = 0 jumpflag = 1 jumpout = 0 %result = quit %finish %if holdflag = 1 %then %start 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 %then %start 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 %C %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 %then %start quitflag = 0 jumpflag = 1 jumpout = 0 %result = quit %finish %if holdflag = 1 %then %start 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 %then %start 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 %then %start quitflag = 0 jumpflag = 1 jumpout = 0 %result = quit %finish %if holdflag = 1 %then %start 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 %C %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 ! %integer %fn deduceq(%integer pattern, indent) %if hd(pattern) & lm # lm %then pattern = cons(pattern, nil) %result = tryinfq(pattern, indent) %end ! END DEDUCEQ ! ! ! -> sysfun(sw) ! ! INPUT OUTPUT sysfun(1): !PRINT %if tdev = 8 %then set42(chtxt) arg1 = unstack %if arg1 = enel %then nooline(1) %else printel(arg1) nooline(1) stack(arg1) %return ! ! sysfun(2): !TYPE %if tdev = 8 %then set42(chtxt) arg1 = unstack %if arg1 = enel %then nooline(1) %else printel(arg1) stack(arg1) %return ! END TYPE ! ! sysfun(3): !GETLIST %if tdev = 8 %then set42(chtxt) blevel = 2 readinline("REPLY:") stack(readlist) prompt(promp) %return ! END GETLIST ! ! sysfun(4): !GETWORD %if tdev = 8 %then set42(chtxt) blevel = 2 readinline("REPLY:") arg1 = headin %if arg1 = rbrak %then stack(empty) %else %start %if arg1 & lm = lm %then %start prstring("NOT A WORD") nooline(1) -> sysfun(4) %finish stack(arg1) %finish prompt(promp) %return ! END GETWORD ! ! sysfun(5): !SAY arg1 = unstack %if arg1 = enel %then nooline(1) %else %start enuf = 0 sep = "" %if arg1 & lm = lm %then printlcon(arg1) %else printwn(arg1) %finish nooline(1) stack(arg1) %return ! END SAY ! ! ! ARITHMETIC sysfun(10): !+ORSUM readynum %if jumpflag = 1 %then %return checksum(arg1, arg2) %if jumpflag = 1 %then %return stack(checksize(arg1 + arg2) << 8 ! nm) %return ! END SUM ! ! ! sysfun(11): !-ORDIFFERENCE readynum %if jumpflag = 1 %then %return checksum(arg1, -arg2) %if jumpflag = 1 %then %return stack(checksize(arg1 - arg2) << 8 ! nm) %return ! END DIFFERENCE ! ! sysfun(12): !*ORTIMES readynum %if jumpflag = 1 %then %return %if arg1 = 0 %or arg2 = 0 %then -> stk %if maxint / imod(arg1) < imod(arg2) %then %start error("INTEGER OVERFLOW IN PRODUCT", empty, 1, in) %return %finish stk: stack(checksize(arg1 * arg2) << 8 ! nm) %return ! END TIMES ! ! sysfun(13): !/ORQUOTIENT readynum %if jumpflag = 1 %then %return %if arg2 = 0 %then %start error("DIVISION BY ZERO IN ", fn, 1, in) %return %finish stack(checksize(arg1 // arg2) << 8 ! nm) %return ! END QUOTIENT ! ! sysfun(14): !REMAINDER readynum %if jumpflag = 1 %then %return %if arg2 = 0 %then %start error("DIVISION BY ZERO IN ", fn, 1, in) %return %finish stack(checksize(arg1 - (arg1 // arg2) * arg2) << 8 ! nm) %return ! END REMAINDER ! ! sysfun(15): !DIVISION readynum %if jumpflag = 1 %then %return %if arg2 = 0 %then %start error("DIVISION BY ZERO IN ", fn, 1, in) %return %finish arg3 = arg1 // arg2 ! ARG3 USED TEMP stack(cons(checksize(arg3) << 8 ! nm, %C cons(checksize(arg1 - arg3 * arg2) << 8 ! nm, nil))) %return ! END DIVISION ! ! sysfun(16): !MAXIMUM readynum %if jumpflag = 1 %then %return %if arg1 >= arg2 %then stack(arg1 << 8 ! nm) %C %else stack(arg2 << 8 ! nm) %return ! END MAXIMUM ! ! sysfun(17): !MINIMUM readynum %if jumpflag = 1 %then %return %if arg1 <= arg2 %then stack(arg1 << 8 ! nm) %C %else stack(arg2 << 8 ! nm) %return ! END MIMIMUM ! ! ! ! CHARACTER AND LIST MANIPULATION ! sysfun(20): !FIRST arg1 = unstack %if arg1 & lm # lm %then %start error("FIRST MUST HAVE A LIST AS ARGUMENT - ", arg1, 1, in) %return %finish %if arg1 = nil %then %start error("FIRST CANNOT HAVE THE EMPTY LIST AS ARGUMENT", empty, 1, in) %return %finish stack(hd(arg1)) %return ! END FIRST ! ! sysfun(21): !LAST arg1 = unstack %if arg1 & lm # lm %then %start error("LAST MUST HAVE A LIST AS ARGUMENT - ", arg1, 1, in) %return %finish %if arg1 = nil %then %start error("LAST CANNOT HAVE THE EMPTY LIST AS ARGUMENT", empty, 1, in) %return %finish %while tl(arg1) # nil %cycle %if quitflag = 1 %then %start quitflag = 0 jumpout = 0 jumpflag = 1 stack(quit) %return %finish %if holdflag = 1 %then %start holdflag = 0 stksys(arg1) error("USER INTERRUPT", empty, 0, in) arg1 = unstksys %if jumpflag = 1 %then %return %finish arg1 = tl(arg1) %repeat stack(hd(arg1)) %return ! END LAST ! ! sysfun(22): !BUTFIRST arg1 = unstack %if arg1 & lm # lm %then %start error("BUTFIRST MUST HAVE A LIST AS ARGUMENT - ", arg1, 1, in) %return %finish %if arg1 = nil %then %start error("BUTFIRST CANNOT HAVE THE EMPTY LIST AS ARGUMENT", empty, %C 1, in) %return %finish stack(tl(arg1)) %return ! END BUTFIRST ! ! sysfun(23): !BUTLAST arg1 = unstack %if arg1 & lm # lm %then %start error("BUTLAST MUST HAVE A LIST AS ARGUMENT - ", arg1, 1, in) %return %finish %if arg1 = nil %then %start error("BUTLAST CANNOT HAVE THE EMPTY LIST AS ARGUMENT", empty, %C 1, in) %return %finish arg2 = nil ! ARG2 USED TEMP %while tl(arg1) # nil %cycle %if quitflag = 1 %then %start quitflag = 0 jumpout = 0 jumpflag = 1 stack(quit) %return %finish %if holdflag = 1 %then %start holdflag = 0 stksys(arg1) stksys(arg2) error("USER INTERRUPT", empty, 0, in) arg2 = unstksys arg1 = unstksys %if jumpflag = 1 %then %return %finish arg2 = cons(hd(arg1), arg2) arg1 = tl(arg1) %repeat ! ARG2 NOW HAS ARG1 LESS LAST ELEMENT REVERSED arg1 = nil %while arg2 # nil %cycle arg1 = cons(hd(arg2), arg1) arg2 = tl(arg2) %repeat stack(arg1) %return ! END BUTLAST ! ! sysfun(24): !WORD arg1 = unstack arg2 = unstack word %return ! END WORD ! ! sysfun(25): !LIST arg1 = unstack arg2 = unstack stack(cons(arg1, cons(arg2, nil))) %return ! ND LIST ! ! sysfun(26): !FIRSTPUT arg1 = unstack arg2 = unstack %if arg2 & lm = lm %then %start ! ARG2 A LIST stack(cons(arg1, arg2)) %return %finish error("FIRSTPUT MUST HAVE A LIST AS SECOND ARGUMENT - ", arg2, 1, in) %return ! END FIRSTPUT ! ! sysfun(27): !LASTPUT arg1 = unstack arg2 = unstack lastput %return ! END LASTPUT ! ! sysfun(28): !JOIN arg1 = unstack arg2 = unstack %if arg1 & lm # lm %then %start error("JOIN MUST HAVE A LIST AS FIRST ARGUMENT - ", arg1, 1, in) %return %finish %if arg2 & lm # lm %then %start error("JOIN MUST HAVE A LIST AS SECOND ARGUMENT - ", arg2, 1, in) %return %finish arg3 = nil ! ARG3 USED TEMP %while arg1 # nil %cycle %if quitflag = 1 %then %start quitflag = 0 jumpout = 0 jumpflag = 1 stack(quit) %return %finish %if holdflag = 1 %then %start holdflag = 0 stksys(arg1) stksys(arg2) stksys(arg3) error("USER INTERRUPT", empty, 0, in) arg3 = unstksys arg2 = unstksys arg1 = unstksys %if jumpflag = 1 %then %return %finish arg3 = cons(hd(arg1), arg3) arg1 = tl(arg1) %repeat ! ARG3 NOW ARG1 REVERSED %while arg3 # nil %cycle arg2 = cons(hd(arg3), arg2) arg3 = tl(arg3) %repeat stack(arg2) ! LISTS APPENDED %return ! END JOIN ! ! sysfun(29): !COUNT arg1 = unstack %if arg1 & lm # lm %then %start error("COUNT MUST HAVE A LIST AS ARGUMENT - ", arg1, 1, in) %return %finish arg2 = 0 %while arg1 # nil %cycle %if quitflag = 1 %then %start quitflag = 0 jumpout = 0 jumpflag = 1 stack(quit) %return %finish %if holdflag = 1 %then %start holdflag = 0 stksys(arg1) error("USER INTERRUPT", empty, 0, in) arg1 = unstksys %if jumpflag = 1 %then %return %finish arg2 = arg2 + 1 arg1 = tl(arg1) %repeat stack(arg2 << 8 ! nm) %return ! END COUNT ! ! ! PREDICATES AND CONDITIONALS ! ! ! ! sysfun(30): !LESSTHAN readynum %if jumpflag = 1 %then %return %if arg1 < arg2 %then stack(true) %else stack(false) %return ! END LESS THAN ! ! sysfun(31): !EQUALTOORLESSTHAN readynum %if jumpflag = 1 %then %return %if arg1 <= arg2 %then stack(true) %else stack(false) %return ! END EQUAL TO OR LESS THAN ! ! sysfun(32): !GREATERTHAN readynum %if jumpflag = 1 %then %return %if arg1 > arg2 %then stack(true) %else stack(false) %return ! END GREATER THAN ! ! sysfun(33): !GREATERTHANOREQUALTO readynum %if jumpflag = 1 %then %return %if arg1 >= arg2 %then stack(true) %else stack(false) %return ! END GREATER THAN OR EQUAL TO ! ! sysfun(34): !EQUALTO arg1 = unstack arg2 = unstack arg3 = equal(arg1, arg2) stack(arg3) %return ! END EQUAL TO ! ! sysfun(35): !ZEROQ arg1 = unstack %if arg1 & nm = nm %and arg1 >> 8 = 0 %then stack(true) %C %else stack(false) %return ! END ZEROQ ! ! sysfun(36): !NUMBERQ arg1 = unstack %if arg1 & nm = nm %then stack(true) %else stack(false) %return ! END NUMBERQ ! ! sysfun(37): !WORDQ arg1 = unstack %if arg1 & wm = wm %then stack(true) %else stack(false) %return ! END WORDQ ! ! sysfun(38): !LISTQ arg1 = unstack %if arg1 & lm = lm %then stack(true) %else stack(false) %return ! END LISTQ ! ! sysfun(39): !EMPTYQ arg1 = unstack %if arg1 = nil %or arg1 = empty %then stack(true) %else stack(false) %return !END EMPTYQ ! ! sysfun(40): !BOTH arg1 = unstack arg2 = unstack %if arg1 = true %and arg2 = true %then stack(true) %else stack(false) %return ! END BOTH ! ! sysfun(41): !EITHER arg1 = unstack arg2 = unstack %if arg1 = true %or arg2 = true %then stack(true) %else stack(false) %return ! END EITHER ! ! sysfun(42): !NOT arg1 = unstack %if arg1 = true %then stack(false) %else stack(true) %return ! END NOT ! ! ! sysfun(50): !TEST arg1 = unstack %if arg1 = true %then tstflg = 1 %else %start %if arg1 = false %then tstflg = 0 %else %start error("TEST MUST HAVE TRUE OR FALSE AS ARGUMENT - ", arg1, 1, %C in) %return %finish %finish stack(arg1) %return ! END TEST ! ! sysfun(51): !IFTRUE %if tstflg = 1 %then %start %if in = nil %then %start error("NULL INSTRUCTION", empty, 1, in) %return %finish stksys(in) eval(in, eachval) in = unstksys %finish %else stack(false) %return ! END IFTRUE ! ! sysfun(52): !IFFALSE %if tstflg = 0 %then %start %if in = nil %then %start error("NULL INSTRUCTION", empty, 1, in) %return %finish stksys(in) eval(in, eachval) in = unstksys %finish %else stack(true) %return ! END IFFALSE ! ! sysfun(53): !IF condlist = hd(in) %if condlist = nil %then %start error("NULL CONDITION", empty, 1, in) %return %finish stksys(in) eval(condlist, eachval) ! EVAL CONDITION in = unstksys %if jumpflag = 1 %then %return cond = unstack ! RESULT OF CONDITION tbranch = hd(tl(in)) fbranch = tl(tl(in)) %if cond = true %then %start !THEN %if tbranch = nil %then %start error("NULL THEN CLAUSE", empty, 1, in) %return %finish %else %start ! EVAL TBRANCH %if hd(tbranch) = start %then %start ! EVAL START...FINISH res = evalstartfin(tbranch) %if jumpflag = 1 %then %return %if goflag = 1 %then %return ! JUMP INSTR %finish %else %start ! NOT START...FINISH stksys(in) eval(tbranch, eachval) dumlab: in = unstksys %if jumpflag = 1 %then %return res = unstack %finish %finish ! FINISH EVAL TBRANCH %finish %else %start !FINISH THEN %if cond = false %then %start ! ELSE %if fbranch = nil %then res = nil %else %start %if hd(fbranch) = start %then %start ! EVAL START...FINISH res = evalstartfin(fbranch) %if jumpflag = 1 %then %return %if goflag = 1 %then %return ! JUMP INSTR %finish %else %start stksys(in) eval(fbranch, eachval) in = unstksys %if jumpflag = 1 %then %return res = unstack %finish %finish %finish %else %start error("BAD CONDITION", empty, 1, in) %return %finish %finish stack(res) %return ! END IF ! ! sysfun(54): !WHILE condlist = hd(in) tbranch = hd(tl(in)) %if condlist = nil %then %start error("NULL CONDITION", empty, 1, in) %return %finish %if tbranch = nil %then %start error("NULL THEN CLAUSE", empty, 1, in) %return %finish res = nil ! RESULT IF COND FALSE FIRST TIME ROUND %cycle stksys(condlist) stksys(tbranch) stksys(in) eval(condlist, eachval) ! EVAL CONDITION in = unstksys tbranch = unstksys condlist = unstksys %if jumpflag = 1 %then %return cond = unstack %exit %if cond = false %unless cond = true %then %start error("BAD CONDITION", empty, 1, in) %return %finish %if hd(tbranch) = start %then %start ! START...FINISH res = evalstartfin(tbranch) %if jumpflag = 1 %then %return %if goflag = 1 %then %return %finish %else %start stksys(condlist) stksys(tbranch) stksys(in) eval(tbranch, eachval) in = unstksys tbranch = unstksys condlist = unstksys %if jumpflag = 1 %then %return res = unstack %finish %if fun # nil %and curfun = nil %then %exit ! SPECIAL TEST FOR RESULT %repeat stack(res) %return ! END WHILE ! ! sysfun(61): !EDIT arg1 = unstack %if arg1 & wm # wm %then %start error("EDIT MUST HAVE A WORD AS ARGUMENT - ", arg1, 1, in) %return %finish arg2 = fnval(arg1 >> 8) ! GET SPEC %if arg2 = 0 %then %start error("PROCEDURE FOR EDIT UNDEFINED - ", arg1, 1, in) %return %finish %if arg2 & userpre # userpre %then %start error("SYSTEM PROCEDURE CANNOT BE EDITED - ", arg1, 1, in) %return %finish %if sourceptr + 2 * fnlen(arg1 >> 8) + 64 > maxsource %C %then baderror("SOURCE FILE SPACE OVERFLOW", empty) oldfn(arg1 >> 8) = fnlen(arg1 >> 8) << 16 ! fntext(arg1 >> 8) newfn = fromlist(arg1, newfn) %unless newfn = nil edit(arg1) %unless fnparse(arg1 >> 8) = 255 %then newfn = cons(arg1, newfn) device = tty nooline(1) printel(arg1) prstring(" EDITED") nooline(1) stack(arg1) %return ! END EDIT ! ! sysfun(62): !MAKE arg1 = unstack arg2 = unstack %if arg1 & wm # wm %then %start error("MAKE MUST HAVE A WORD AS FIRST ARGUMENT - ", arg1, 1, in) %return %finish setval(arg1, arg2, envir) stack(arg2) %return ! END MAKE ! ! sysfun(63): !NEW arg1 = unstack %if arg1 & wm = wm %then arg1 = cons(arg1, nil) %else chklist(arg1) %if jumpflag = 1 %then %return arg2 = listlen(arg1) %if arg2 = 0 %then stack(nil) %and %return %if envir = basenvir %then %start ! CREATE GLOBALS %cycle arg3 = 1, 1, arg2 setval(hd(arg1), nil, envir) arg1 = tl(arg1) %repeat %finish %else %start ! CREATE LOCALS %cycle arg3 = 1, 1, arg2 stack(nil) ! VALUES ONTO STACK %repeat envir = setbind(arg1, envir) %finish stack(nil) %return ! END NEW ! ! sysfun(64): !GO arg1 = unstack %if arg1 & nm # nm %then %start error("GO NEEDS A NUMBER - ", arg1, 1, in) %return %finish stack(arg1) goflag = 1 %return ! END GO ! ! ! sysfun(65): !STOP curfun = nil !CURFUN=CONS(NIL,NIL); ! APPLYUSR STOPS WHEN A SINGLE LINE LEFT stack(true) %return ! END STOP ! ! sysfun(66): !RESULT(OUTPUT) curfun = nil !CURFUN=CONS(NIL,NIL) ! STACK(UNSTACK) %return ! END RESULT ! ! sysfun(70): !SHOW arg1 = unstack %if arg1 & wm = wm %then arg1 = cons(arg1, nil) %if arg1 & lm # lm %then %start nooline(1) error1("NON-WORD FOR SHOW - ", arg1) -> sh2 %finish %while arg1 # nil %cycle %if quitflag = 1 %then %start quitflag = 0 jumpout = 0 jumpflag = 1 stack(quit) %return %finish %if holdflag = 1 %then %start holdflag = 0 stksys(arg1) error("USER INTERRUPT", empty, 0, in) arg1 = unstksys %if jumpflag = 1 %then %return %finish arg2 = hd(arg1) arg1 = tl(arg1) nooline(1) %if arg2 & wm # wm %then %start error1("NON WORD FOR SHOW - ", arg2) -> sh1 %finish arg3 = fnval(arg2 >> 8) ! GET SPEC %if arg3 = 0 %then %start error1("UNDEFINED PROCEDURE FOR SHOW - ", arg2) -> sh1 %finish %if arg3 & userpre # userpre %then %start error1("SYSTEM PROCEDURE FOR SHOW - ", arg2) -> sh1 %finish arg3 = fntext(arg2 >> 8) %until source(arg4) = 'E' %and source(arg4 + 1) = 'N' %C %and source(arg4 + 2) = 'D' %cycle arg4 = arg3 printfnline(arg3) %repeat sh1: %repeat sh2: stack(true) %return ! END SHOW ! ! sysfun(71): !SHOWTITLES arg2 = -1 nooline(1) %cycle arg1 = 0, 1, 1022 %if quitflag = 1 %then %start quitflag = 0 jumpout = 0 jumpflag = 1 stack(quit) %return %finish %if holdflag = 1 %then %start holdflag = 0 error("USER INTERRUPT", empty, 0, in) %if jumpflag = 1 %then %return %finish %if fnval(arg1) & userpre = userpre %then %start arg2 = fntext(arg1) printfnline(arg2) %finish !PRINTLINE(HD(FNVAL(ARG1)&M16!LM)) %AND ARG2=1 %repeat %if arg2 < 0 %then prstring("NO USER PROCEDURES DEFINED YET") %C %and nooline(1) stack(true) %return ! END SHOWTITLES ! ! sysfun(72): !SHOWALL arg2 = -1 %cycle arg1 = 0, 1, 1022 %if quitflag = 1 %then %start quitflag = 0 jumpout = 0 jumpflag = 1 stack(quit) %return %finish %if holdflag = 1 %then %start holdflag = 0 error("USER INTERRUPT", empty, 0, in) %if jumpflag = 1 %then %return %finish %if fnval(arg1) & userpre = userpre %then %start nooline(1) arg2 = fntext(arg1) %until source(arg3) = 'E' %and source(arg3 + 1) = 'N' %C %and source(arg3 + 2) = 'D' %cycle arg3 = arg2 printfnline(arg2) %repeat %finish %repeat %if arg2 < 0 %then %start nooline(1) prstring("NO USER PROCEDURES DEFINED YET") nooline(1) %finish stack(true) %return ! END SHOWALL ! ! sysfun(73): !SHOWNEW nooline(1) %if newfn = nil %then %start prstring("NO NEW PROCEDURES") nooline(1) stack(true) %return %finish arg2 = newfn %while arg2 # nil %cycle %if quitflag = 1 %then %start quitflag = 0 jumpout = 0 jumpflag = 1 stack(quit) %return %finish %if holdflag = 1 %then %start holdflag = 0 stksys(arg2) error("USER INTERRUP", empty, 0, in) arg2 = unstksys %if jumpflag = 1 %then %return %finish arg1 = hd(arg2) arg3 = fntext(arg1 >> 8) printfnline(arg3) arg2 = tl(arg2) %repeat stack(true) %return ! END SHOWNEW ! ! sysfun(74): !OLDDEF arg1 = unstack %if arg1 & wm # wm %then %start error("OLDDEF MUST HAVE A WORD FOR ARGUMENT - ", arg1, 1, in) %return %finish %if oldfn(arg1 >> 8) = 0 %then %start error(" NO STANDBY DEF FOR PROCEDURE - ", arg1, 1, in) %return %finish newfn = fromlist(arg1, newfn) %unless newfn = nil arg2 = fnlen(arg1 >> 8) << 16 ! fntext(arg1 >> 8) fntext(arg1 >> 8) = oldfn(arg1 >> 8) & X'FFFF' fnlen(arg1 >> 8) = oldfn(arg1 >> 8) >> 16 w1 = checkfnhead(arg1) %if w1 = fault %then fnparse(arg1 >> 8) = 255 oldfn(arg1 >> 8) = arg2 newfn = cons(arg1, newfn) %unless w1 = fault prstring("STANDBY DEFINITION OF ") prstring(wa(arg1 >> 8) . " RESTORED") nooline(1) stack(arg1) %return ! END OLDDEF ! ! sysfun(75): !GETFILE arg1 = unstack %if arg1 & wm # wm %then %start error("GETFILE MUST HAVE A WORD AS ARGUMENT - ", arg1, 1, in) %return %finish userfile = wa(arg1 >> 8) %if cactfile = 2 %then getmaster mdind = findfile %if jumpflag = 1 %then stack(mdind) %and %return cactfile = 1 %if mdind < 0 %then %start ! FILE NOT FOUND IN MASTER DIRECTORY cluserfl claimmaster ! OPEN MASTERFILE FOR WRITE,UNSHARED ACCESS %if jumpflag = 1 %then %return %if mdents = 62 %then getpage(3) %else getpage(2) mdents = mdents + 1 mdind = mdents udnam(mdents) = userfile udpage(mdents) = udp nooline(1) printel(arg1) prstring(" CREATED") freemaster ! FREE MASTERFILE FOR SHARED ACCESS %finish nooline(1) printel(arg1) prstring(" ACTIVE") nooline(1) stack(true) %return ! END GETFILE ! ! sysfun(76): !LOADDOT arg1 = unstack %if cactfile = 0 %then %start error("NO FILE CURRENTLY ACTIVE", empty, 1, in) %return %finish nooline(1) %if arg1 & wm = wm %then arg1 = cons(arg1, nil) %if arg1 & lm # lm %C %then error1("LOAD CANNOT HAVE A NUMBER AS ARGUMENT - ", arg1) %C %and -> ld5 %if cactfile = 2 %then %start gothdir %if jumpflag = 1 %then %return %finish libload = 1 mdmap(filstart + mdp * 4096) udp = 0 %while arg1 # nil %cycle w1 = hd(arg1) arg1 = tl(arg1) %if w1 & wm # wm %then %start error1("NON-WORD FOR LOAD - ", w1) -> ld3 %finish %if udp = udpage(mdind) %then -> ld2 %else getudp %if udents = 0 %then %start prstring("NO USER PROCEDURES SAVED") nooline(1) -> ld4 %finish -> ld2 ld1: udmap(filstart + udp * 4096) ld2: arg2 = 1 %while arg2 <= udents %cycle %if quitflag = 1 %then %start quitflag = 0 jumpout = 0 jumpflag = 1 stack(quit) -> ld4 %finish %if holdflag = 1 %then %start holdflag = 0 libload = 0 device = tty %if cactfile = 2 %then frothdir error("USER INTERRUPT - PROCESS ABANDONNED", empty, 1, in) %return %finish %if arg2 = 61 %then udp = udnext %and -> ld1 %if funnam(arg2) = wa(w1 >> 8) %then %start txtmap(filstart + txtpage(arg2) * 4096) index = shortint(txtind(1, arg2)) device = disc starttext = sourceptr %until headin = end %cycle readinline(promp) copyline %repeat newfn = fromlist(w1, newfn) %unless newfn = nil %if fntext(w1 >> 8) # 0 %C %then oldfn(w1 >> 8) = fnlen(w1 >> 8) << 16 ! fntext(w1 >> 8) fnlen(w1 >> 8) = sourceptr - starttext fntext(w1 >> 8) = starttext arg3 = checkfnhead(w1) %if arg3 = fault %then fnparse(w1 >> 8) = 255 %C %else newfn = cons(w1, newfn) prstring(wa(w1 >> 8)) prstring(" LOADED") nooline(1) -> ld3 %finish arg2 = arg2 + 1 %repeat prstring(wa(w1 >> 8)) prstring(" NOT SAVED") nooline(1) ld3: %repeat ld4: device = tty %if cactfile = 2 %then frothdir libload = 0 ld5: %unless jumpflag = 1 %then stack(true) %return ! END LOAD ! ! sysfun(77): !SAVE arg3 = unstack %if cactfile = 0 %then %start error(" NO FILE CURRENTLY ACTIVE", empty, 1, in) %return %finish %if cactfile = 2 %then %start error("CANNOT SAVE TO A LIBRARY FILE", empty, 1, in) %return %finish nooline(1) %if arg3 & wm = wm %then arg3 = cons(arg3, nil) %if arg3 & lm # lm %then error1("NON-WORD FOR SAVE - ", arg3) %C %and -> save2 cluserfl claimmaster %if jumpflag = 1 %then %return mdmap(filstart + mdp * 4096) endmap device = disc %while arg3 # nil %cycle %if quitflag = 1 %then %start quitflag = 0 jumpout = 0 jumpflag = 1 device = tty freemaster stack(quit) %return %finish %if holdflag = 1 %then %start holdflag = 0 device = tty freemaster error("USER INTERRUPT - PROCESS ABANDONNED", empty, 1, in) %return %finish arg1 = hd(arg3) arg3 = tl(arg3) %if arg1 & wm # wm %then %start error1(" NON-WORD FOR SAVE - ", arg1) -> saverep %finish arg2 = fnparse(arg1 >> 8) %if arg2 = 255 %then %start error1("PROCEDURE HAS FAULTY FIRST LINE", arg1) -> saverep %finish arg2 = fnval(arg1 >> 8) %if arg2 = 0 %then %start error1(" UNDEFINED PROCEDURE FOR SAVE - ", arg1) -> saverep %finish %if arg2 & userpre # userpre %then %start error1("YOU CANNOT SAVE A SYSTEM PROCEDURE - ", arg1) -> saverep %finish mapend w1 = fntext(arg1 >> 8) ! START OF TEXT w2 = w1 + fnlen(arg1 >> 8) ! END OF TEXT %until w1 >= w2 %cycle w3 = w1 ! SAVE PTR TO START OF LINE printfnline(w1) %repeat ! ! UPDATE DIRECTORY updir(arg1) ! newfn = fromlist(arg1, newfn) %unless newfn = nil prstring(wa(arg1 >> 8)) prstring(" SAVED") nooline(1) saverep: %repeat device = tty freemaster save2: stack(true) %return ! END SAVE ! ! sysfun(78): !SAVENEW %if cactfile = 0 %then %start error("NO FILE CURRENTLY ACTIVE", empty, 1, in) %return %finish %if cactfile = 2 %then %start error("CANNOT SAVE TO A LIBRARY FILE", empty, 1, in) %return %finish nooline(1) %if newfn = nil %then %start prstring("NO USER PROCEDURES DEFINED OR EDITED YET") nooline(1) stack(true) %return %finish cluserfl claimmaster %if jumpflag = 1 %then %return mdmap(filstart + mdp * 4096) endmap device = disc %while newfn # nil %cycle %if quitflag = 1 %then %start quitflag = 0 jumpout = 0 jumpflag = 1 device = tty freemaster stack(quit) %return %finish %if holdflag = 1 %then %start holdflag = 0 device = tty freemaster error("USER INTERRUPT - PROCESS ABANDONNED", empty, 1, in) %return %finish mapend arg1 = hd(newfn) w1 = fntext(arg1 >> 8) ! START OF TEXT w2 = w1 + fnlen(arg1 >> 8) ! END OF TEXT %until w1 >= w2 %cycle w3 = w1 ! SAVE PTR TO START OF LINE printfnline(w1) %repeat ! UPDATE DIR updir(arg1) prstring(wa(arg1 >> 8)) prstring(" SAVED") nooline(1) newfn = tl(newfn) %repeat device = tty freemaster stack(true) %return ! END SAVENEW ! ! sysfun(79): !FORGET arg3 = unstack %if cactfile = 0 %then %start error(" NO FILE CURRENTLY ACTIVE", empty, 1, in) %return %finish %if cactfile = 2 %then %start error("CANNOT FORGET LIBRARY PROCEDURES", empty, 1, in) %return %finish nooline(1) %if arg3 & wm = wm %then arg3 = cons(arg3, nil) %if arg3 & lm # lm %then %start error1("FORGET CANNOT HAVE A NUMBER AS ARGUMENT - ", arg3) stack(true) %return %finish cluserfl claimmaster %if jumpflag = 1 %then %return udp = 0 mdmap(filstart + mdp * 4096) %while arg3 # nil %cycle arg1 = hd(arg3) arg3 = tl(arg3) %if arg1 & wm # wm %then %start error1(" NON-WORD FOR FORGET - ", arg1) -> fg3 %finish %if udp = udpage(mdind) %then -> fg2 %else getudp %if udents = 0 %then %start prstring("NO USER PROCEDURES SAVED") nooline(1) -> fg4 %finish fg1: udmap(filstart + udp * 4096) fg2: arg2 = 1 %while arg2 <= udents %cycle %if quitflag = 1 %then %start quitflag = 0 jumpout = 0 jumpflag = 1 freemaster stack(quit) %return %finish %if holdflag = 1 %then %start holdflag = 0 freemaster error("USER INTERRUPT - PROCESS ABANDONNED", empty, 1, in) %return %finish %if arg2 = 61 %then udp = udnext %and -> fg1 %if funnam(arg2) = wa(arg1 >> 8) %then %start funnam(arg2) = "" txtpage(arg2) = 0 prstring(wa(arg1 >> 8) . " FORGOTTEN") nooline(1) -> fg3 %finish ! SPACES IN USER DIR ONLY AT MOMENT arg2 = arg2 + 1 %repeat prstring(wa(arg1 >> 8)) prstring(" NOT SAVED") nooline(1) fg3: %repeat fg4: freemaster stack(true) %return ! END FORGET ! ! sysfun(80): !SHOWSAVEDTITLES %if cactfile = 0 %then %start error("NO FILE CURRENTLY ACTIVE", empty, 1, in) %return %finish %if cactfile = 2 %then %start gothdir %if jumpflag = 1 %then %return %finish mdmap(filstart + mdp * 4096) udp = udpage(mdind) txtp = 0 nooline(1) ss5: udmap(filstart + udp * 4096) arg2 = 1 %if udents = 0 %then %start prstring("NO USER PROCEDURES SAVED YET") nooline(1) -> ss6 %finish %while arg2 <= udents %cycle %if arg2 = 61 %then udp = udnext %and -> ss5 %if quitflag = 1 %then %start quitflag = 0 jumpout = 0 jumpflag = 1 %if cactfile = 2 %then frothdir stack(quit) %return %finish %if holdflag = 1 %then %start holdflag = 0 %if cactfile = 2 %then frothdir error("USER INTERRUPT - PROCESS ABANDONNED", empty, 1, in) %return %finish %if txtpage(arg2) = 0 %then %start prstring("FORGOTTEN PROCEDURE") nooline(1) %finish %else %start %unless txtp = txtpage(arg2) %then gettxtp(arg2) index = shortint(txtind(1, arg2)) device = disc arg3 = readline device = tty printline(arg3) %finish arg2 = arg2 + 1 %repeat ss6: %if cactfile = 2 %then frothdir stack(true) %return ! END SHOWSAVEDTITLES ! ! sysfun(81): !SHOWSAVED arg1 = unstack %if cactfile = 0 %then %start error(" NO FILE CURRENTLY ACTIVE", empty, 1, in) %return %finish %if arg1 & wm = wm %then arg1 = cons(arg1, nil) %if arg1 & lm # lm %then %start nooline(1) error1("SHOWSAVED CANNOT HAVE A NUMBER AS ARGUMENT - ", arg1) -> ss10 %finish %if cactfile = 2 %then %start gothdir %if jumpflag = 1 %then %return %finish mdmap(filstart + mdp * 4096) udp = 0 %while arg1 # nil %cycle w1 = hd(arg1) arg1 = tl(arg1) nooline(1) %if w1 & wm # wm %then %start error1(" NON-WORD FOR SHOWSAVED - ", w1) -> ss3 %finish %if udp = udpage(mdind) %then -> ss2 %else getudp %if udents = 0 %then %start prstring("NO USER PROCEDURES SAVED") nooline(1) -> ss4 %finish -> ss2 ss1: udmap(filstart + udp * 4096) ss2: arg3 = 1 %while arg3 <= udents %cycle %if quitflag = 1 %then %start quitflag = 0 jumpout = 0 jumpflag = 1 %if cactfile = 2 %then frothdir stack(quit) %return %finish %if arg3 = 61 %then udp = udnext %and -> ss1 %if holdflag = 1 %then %start holdflag = 0 %if cactfile = 2 %then frothdir error("USER INTERRUPT - PROCESS ABANDONNED", empty, 1, in) %return %finish %if funnam(arg3) = wa(w1 >> 8) %then %start txtmap(filstart + txtpage(arg3) * 4096) index = shortint(txtind(1, arg3)) rl: device = disc arg2 = readline device = tty printline(arg2) %if hd(arg2) = end %then -> ss3 -> rl %finish arg3 = arg3 + 1 %repeat prstring(wa(w1 >> 8)) prstring(" NOT SAVED") nooline(1) ss3: %repeat ss4: %if cactfile = 2 %then frothdir ss10: stack(true) %return ! END SHOWSAVED ! ! sysfun(82): !SHOWSAVEDALL %if cactfile = 0 %then %start error("NO FILE CURRENTLY ACTIVE", empty, 1, in) %return %finish %if cactfile = 2 %then %start gothdir %if jumpflag = 1 %then %return %finish mdmap(filstart + mdp * 4096) udp = udpage(mdind) txtp = 0 ssall1: udmap(filstart + udp * 4096) %if udents = 0 %then %start nooline(1) prstring("NO USER PROCEDURES SAVED YET") nooline(1) -> ssall2 %finish arg2 = 1 %while arg2 <= udents %cycle %if quitflag = 1 %then %start quitflag = 0 jumpout = 0 jumpflag = 1 %if cactfile = 2 %then frothdir stack(quit) %return %finish %if holdflag = 1 %then %start holdflag = 0 %if cactfile = 2 %then frothdir error("USER INTERRUPT - PROCESS ABANDONNED", empty, 1, in) %return %finish %if arg2 = 61 %then udp = udnext %and -> ssall1 %if txtpage(arg2) = 0 %then %start prstring("FORGOTTEN PROCEDURE") nooline(1) %finish %else %start %unless txtp = txtpage(arg2) %then gettxtp(arg2) nooline(1) index = shortint(txtind(1, arg2)) %cycle device = disc arg3 = readline device = tty printline(arg3) %if hd(arg3) = end %then %exit %repeat %finish arg2 = arg2 + 1 %repeat ssall2: %if cactfile = 2 %then frothdir stack(true) %return ! END SHOWSAVEDALL ! ! sysfun(83): !LOADSAVED %if cactfile = 0 %then %start error(" NO FILE CURRENTLY ACTIVE", empty, 1, in) %return %finish %if cactfile = 2 %then %start gothdir %if jumpflag = 1 %then %return %finish mdmap(filstart + mdp * 4096) udmap(filstart + udpage(mdind) * 4096) nooline(1) %if udents = 0 %then %start prstring(" NO USER PROCEDURES SAVED YET") nooline(1) %if cactfile = 2 %then frothdir stack(true) %return %finish txtp = 0 libload = 1 ls1: arg1 = 1 %while arg1 <= udents %cycle %if quitflag = 1 %then %start quitflag = 0 jumpout = 0 jumpflag = 1 stack(quit) -> ls3 %finish %if holdflag = 1 %then %start holdflag = 0 device = tty libload = 0 %if cactfile = 2 %then frothdir error("USER INTERRUPT - PROCESS ABANDONNED", empty, 1, in) %return %finish %if arg1 = 61 %then udmap(filstart + udnext * 4096) %and -> ls1 %if txtpage(arg1) = 0 %then -> ls2 %unless txtp = txtpage(arg1) %then gettxtp(arg1) index = shortint(txtind(1, arg1)) device = disc starttext = sourceptr %until headin = end %cycle readinline(promp) copyline %repeat arg2 = hash(funnam(arg1)) newfn = fromlist(arg2, newfn) %unless newfn = nil %if fntext(arg2 >> 8) # 0 %C %then oldfn(arg2 >> 8) = fnlen(arg2 >> 8) << 16 ! fntext(arg2 >> 8) fnlen(arg2 >> 8) = sourceptr - starttext fntext(arg2 >> 8) = starttext arg3 = checkfnhead(arg2) %if arg3 = fault %then fnparse(arg2 >> 8) = 255 %C %else newfn = cons(arg2, newfn) ls2: arg1 = arg1 + 1 %repeat stack(true) ls3: device = tty %if cactfile = 2 %then frothdir libload = 0 %return ! END LOADSAVED ! ! sysfun(84): !DESTROY arg1 = unstack nooline(1) %if arg1 & wm = wm %then arg1 = cons(arg1, nil) %if arg1 & lm # lm %then %start error1("DESTROY MUST HAVE A WORD AS ARGUMENT -", arg1) stack(true) %return %finish %unless cactfile = 2 %then cluserfl claimmaster %if jumpflag = 1 %then %return mdmap(filstart) %if mdents = 0 %then %start prstring("NO FILES CREATED YET") nooline(1) -> d4 %finish %while arg1 # nil %cycle arg2 = hd(arg1) arg1 = tl(arg1) %if arg2 & wm # wm %then %start error1("NON-WORD FOR DESTROY - ", arg2) -> d3 %finish mdmap(filstart) d2: arg3 = 1 %while arg3 <= mdents %cycle %if quitflag = 1 %then %start quitflag = 0 jumpout = 0 jumpflag = 1 freemaster stack(quit) %return %finish %if holdflag = 1 %then %start holdflag = 0 freemaster error("USER INTERRUPT - PROCESS ABANDONNED", empty, 1, in) %return %finish %if arg3 = 63 %then mdmap(filstart + mdnext * 4096) %and -> d2 %if udnam(arg3) = wa(arg2 >> 8) %then %start udnam(arg3) = "" udpage(arg3) = 0 prstring(wa(arg2 >> 8) . " DESTROYED") nooline(1) %if userfile = wa(arg2 >> 8) %and owner = emasuser %C %then nofile -> d3 %finish arg3 = arg3 + 1 %repeat prstring(wa(arg2 >> 8) . " DOES NOT EXIST") nooline(1) d3: %repeat d4: freemaster stack(true) %return ! END DESTROY ! ! sysfun(85): !BORROWFILE chlib %if jumpflag = 1 %then %return %unless cactfile = 2 %then cluserfl owner = wstr1 userfile = wa(arg2 >> 8) gothdir %if jumpflag = 1 %then %return frothdir cactfile = 2 nooline(1) printel(arg1) prstring(" ") printel(arg2) prstring(" EXISTS") nooline(1) stack(true) %return ! END BORROWFILE ! ! sysfun(86): !LIBRARY chlib %if jumpflag = 1 %then %return savefile %unless cactfile = 2 %then closesm(4) %and clear("4") ! MAP ONTO LIB OWNER"S DIRECTORY userfile = wa(arg2 >> 8) gothdir %if jumpflag = 1 %then %return ! GET LIBRARY DIR cactfile = cactfile + 1 libload = 1 udp = udpage(mdind) lib1: udmap(filstart + udp * 4096) arg1 = 1 %while arg1 <= udents %cycle %if quitflag = 1 %then %start quitflag = 0 jumpout = 0 jumpflag = 1 stack(quit) %exit %finish %if holdflag = 1 %then %start holdflag = 0 device = tty cactfile = cactfile - 1 frothdir restfile libload = 0 error("USER INTERRUPT - PROCESS ABANDONNED", empty, 1, in) %return %finish %if arg1 = 61 %then udp = udnext %and -> lib1 %unless txtpage(arg1) = 0 %then %start %unless txtp = txtpage(arg1) %then gettxtp(arg1) index = shortint(txtind(1, arg1)) device = disc starttext = sourceptr %until headin = end %cycle readinline(promp) copyline %repeat arg2 = hash(funnam(arg1)) newfn = fromlist(arg2, newfn) %unless newfn = nil %if fntext(arg2 >> 8) # 0 %C %then oldfn(arg2 >> 8) = fnlen(arg2 >> 8) << 16 ! fntext(arg2 >> 8) fnlen(arg2 >> 8) = sourceptr - starttext fntext(arg2 >> 8) = starttext arg3 = checkfnhead(arg2) %if arg3 = fault %then fnparse(arg2 >> 8) = 255 %C %else newfn = cons(arg2, newfn) %finish arg1 = arg1 + 1 %repeat device = tty cactfile = cactfile - 1 frothdir restfile libload = 0 %if jumpflag # 1 %then stack(true) %return ! END LIBRARY ! ! sysfun(87): !FILEINFO %if cactfile = 0 %then %start error("NO FILE CURRENTLY ACTIVE", empty, 1, in) %return %finish %if cactfile = 2 %then %start gothdir %if jumpflag = 1 %then %return %finish arg1 = fnents nooline(1) prstring("NO OF ENTRIES IN FILE DIRECTORY= ") write(arg1, 6) nooline(1) prstring("NXT FREE PAGE IN USER TEXT AREA =") write(endtxt + 1, 6) nooline(1) prstring("NXT FREE INDEX =") write(shortint(endind(1)), 6) nooline(1) %if udp # udpage(mdind) %then getudp %if udents = 0 %then -> fi2 fi1: arg1 = 1 %while arg1 <= udents %cycle %if quitflag = 1 %then %start quitflag = 0 jumpout = 0 jumpflag = 1 %if cactfile = 2 %then frothdir stack(quit) %return %finish %if holdflag = 1 %then %start holdflag = 0 %if cactfile = 2 %then frothdir error("USER INTERRUPT - PROCESS ABANDONNED", empty, 1, in) %return %finish %if arg1 = 61 %then %start udp = udnext udmap(filstart + udp * 4096) -> fi1 %finish nooline(1) %if funnam(arg1) = "" %then %start prstring(" FORGOTTEN PROCEDURE") nooline(1) %finish %else %start prstring(" ENTRY NO = ") write(arg1, 6) nooline(1) prstring(" STARTING PAGE =") write(txtpage(arg1) + 1, 6) nooline(1) prstring(" STARTING INDEX =") write(shortint(txtind(1, arg1)), 6) nooline(1) prstring(" TEXT =") nooline(2) %unless txtp = txtpage(arg1) %then gettxtp(arg1) index = shortint(txtind(1, arg1)) %cycle device = disc arg2 = readline device = tty printline(arg2) %if hd(arg2) = end %then %exit %repeat %finish arg1 = arg1 + 1 %repeat fi2: stack(true) %if cactfile = 2 %then frothdir %return ! END FILEINFO ! ! sysfun(88): !LISTFILE %if cactfile = 0 %then %start error(" NO FILE CURRENTLY ACTIVE", empty, 1, in) %return %finish %if cactfile = 2 %then %start gothdir %if jumpflag = 1 %then %return %finish arg1 = fnents %if udents = 0 %then %start printstring("FILE EMPTY") newline -> lf3 %finish define("10,.LP") ! USUALLY .LP selectoutput(10) newline printstring("****** PROCEDURE DIRECTORY FOR ") %if owner = "" %then printstring("USER ") %C %else printstring("LIBRARY ") printstring("FILE " . userfile . " ******") newlines(2) printstring(" NO OF PROCEDURES SAVED/FORGOTTEN = ") write(arg1, 8) newline printstring(" ENTRY NO START PAGE START INDEX PROCEDURE NAME") %if udp # udpage(mdind) %then getudp lf1: arg1 = 1 %while arg1 <= udents %cycle %if quitflag = 1 %then %start quitflag = 0 jumpout = 0 jumpflag = 1 stack(quit) -> lf4 %finish %if holdflag = 1 %then %start holdflag = 0 selectoutput(0) closestream(10) clear("10") %if cactfile = 2 %then frothdir error("USER INTERRUPT - PROCESS ABANDONNED", empty, 1, in) %return %finish %if arg1 = 61 %then %start udp = udnext udmap(filstart + udp * 4096) -> lf1 %finish newline write(arg1, 6) %if funnam(arg1) = "" %then %start spaces(7) printstring(" FORGOTTEN PROCEDURE ") -> rep136 %finish spaces(10) write(txtpage(arg1) + 1, 6) spaces(8) write(shortint(txtind(1, arg1)), 6) spaces(8) printstring(funnam(arg1)) rep136: arg1 = arg1 + 1 %repeat newlines(2) printstring("****** TEXT AREA ******") %if udp # udpage(mdind) %then getudp txtp = 0 lf2: arg1 = 1 %while arg1 <= udents %cycle %if quitflag = 1 %then %start quitflag = 0 jumpout = 0 jumpflag = 1 stack(quit) -> lf4 %finish %if holdflag = 1 %then %start holdflag = 0 selectoutput(0) closestream(10) clear("10") %if cactfile = 2 %then frothdir error("USER INTERRUPT - PROCESS ABANDONNED", empty, 11, in) %return %finish %if arg1 = 61 %then %start udp = udnext udmap(filstart + udp * 4096) -> lf2 %finish %unless funnam(arg1) = "" %then %start %unless txtp = txtpage(arg1) %then gettxtp(arg1) arg2 = shortint(txtind(1, arg1)) newline lff: printsymbol(fntxt(arg2)) %if fntxt(arg2) = termin %then %start arg2 = arg2 + 1 %if arg2 > shortint(txtents(1)) %then -> lf5 chkind(arg2) %if fntxt(arg2) = 'T' %then -> lf5 %finish %else arg2 = arg2 + 1 %and chkind(arg2) -> lff %finish lf5: arg1 = arg1 + 1 %repeat lf4: selectoutput(0) closestream(10) clear("10") lf3: %if cactfile = 2 %then frothdir %unless jumpflag = 1 %then stack(true) %return ! END LISTFILE ! ! sysfun(89): !SHOWFILES %if cactfile = 2 %then getmaster mdmap(filstart) nooline(1) %if mdents = 0 %then prstring("NO FILES CREATED YET") %and -> sf2 prstring(" LOGO MASTER DIRECTORY ") nooline(2) prstring(" ENTRY NO FILENAME ") sf1: arg1 = 1 %while arg1 <= mdents %cycle %if quitflag = 1 %then %start quitflag = 0 jumpout = 0 jumpflag = 1 %if cactfile = 2 %then cluserfl stack(quit) %return %finish %if holdflag = 1 %then %start holdflag = 0 %if cactfile = 2 %then cluserfl error("USER INTERRUPT - PROCESS ABANDONNED", empty, 1, in) %return %finish %if arg1 = 63 %then mdmap(filstart + mdnext * 4096) %and -> sf1 nooline(1) write(arg1, 9) spaces(9) %if udnam(arg1) = "" %then prstring("FORGOTTEN FILE") %else %start prstring(udnam(arg1)) %finish arg1 = arg1 + 1 %repeat sf2: nooline(1) stack(true) %if cactfile = 2 %then cluserfl %return ! END SHOWFILES ! ! sysfun(90): !SUPERQUIT jumpflag = 1 jumpout = 100 superjmp = 1 stack(fn) %return ! END SUPERQUIT ! ! sysfun(91): !ABORT arg1 = unstack %if arg1 & nm # nm %or arg1 < 0 %then %start error("ABORT MUST HAVE A POSITIVE NUMBER AS ARGUMENT - ", arg1, %C 1, in) %return %finish jumpflag = 1 jumpout = arg1 >> 8 stack(fn) %return ! END ABORT ! ! sysfun(92): !QUIT jumpflag = 1 jumpout = 100 stack(fn) %return ! END QUIT ! ! sysfun(93): !CONTINUE %if severity = 1 %then %start error("CANNOT CONTINUE FROM LAST ERROR", empty, 1, in) %return %finish jumpflag = 1 jumpout = -1 stack(fn) %return ! END CONTINUE ! ! sysfun(94): !SENDBACK arg1 = unstack ! VALUE TO BE SENT arg2 = unstack ! FN TO BE SENT TO OR NUMBER OF FNS TO BE EXITED %if arg2 & nm = nm %then %start %if arg2 < 0 %then %start 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 %then %start 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 %then %start ! FOUND IT sendflag = arg3 + 1 ! NO OF RETURNS TO BE MADE TO GET THERE jumpflag = 1 stack(arg1) %return %finish %else %start ! 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 - ", 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 %then %return ! 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 %then %start printel(logoname) nooline(1) %finish %else %start arg2 = arg1 %while bname(arg2) # 0 %cycle arg2 = arg2 - 1 %repeat printel(bvalue(arg2)) ! FN NAME nooline(1) %if arg2 = arg1 %then %start prstring("NO LOCALS") nooline(1) %finish %else %start arg2 = arg2 + 1 %while arg2 <= arg1 %cycle spaces(2) printel(bname(arg2)) prstring(":-") printel(bvalue(arg2)) nooline(1) arg2 = arg2 + 1 %repeat %finish %finish rl107: arg3 = stkpnt ! SAVV STACK readinline("RESULT:") plevel = 0 arg1 = parseline(0) %if arg1 = fault %then stkpnt = arg3 %and -> rl107 stksys(in) eval(arg1, eachval) in = unstksys %if jumpflag = 1 %then %start ! SPECIAL FOR RETRY %if superjmp = 1 %then %return jumpflag = 0 jumpout = 0 sendflag = 0 stkpnt = arg3 -> rl107 %finish prompt(promp) ! STACK(UNSTACK) %return ! END CALLUSER ! ! sysfun(97): !FNCALLS arg1 = envir nooline(1) %while arg1 > 1022 %cycle %if quitflag = 1 %then %start quitflag = 0 jumpout = 0 jumpflag = 1 stack(quit) %return %finish %if holdflag = 1 %then %start holdflag = 0 error("USER INTERRUPT", empty, 0, in) %if jumpflag = 1 %then %return %finish %if bname(arg1) = 0 %then %start printel(bvalue(arg1)) nooline(1) %finish arg1 = arg1 - 1 %repeat printel(logoname) nooline(1) stack(logoname) %return ! END FNCALLS ! ! sysfun(98): !FNVALS arg1 = envir nooline(1) %while arg1 > 1022 %cycle %if quitflag = 1 %then %start quitflag = 0 jumpout = 0 jumpflag = 1 stack(quit) %return %finish %if holdflag = 1 %then %start holdflag = 0 error("USER INTERRUPT", empty, 0, in) %if jumpflag = 1 %then %return %finish arg2 = arg1 %while bname(arg2) # 0 %cycle arg2 = arg2 - 1 %repeat ! ARG2 POINTS TO CURRENT BOTTOM printel(bvalue(arg2)) ! FUNCTION NAME prstring(":-") nooline(1) arg3 = arg2 + 1 %while arg3 <= arg1 %cycle spaces(4) printel(bname(arg3)) space printel(bvalue(arg3)) nooline(1) arg3 = arg3 + 1 %repeat nooline(1) arg1 = arg2 - 1 %repeat printel(logoname) nooline(1) stack(logoname) %return ! END FNVALS ! ! sysfun(99): !ABBREV redef = 0 arg1 = unstack arg2 = unstack %if arg1 & wm # wm %then %start error("ABBREV MUST HAVE A WORD AS FIRST ARGUMENT - ", arg1, 1, in) %return %finish %if arg2 & wm # wm %then %start error("ABBREV MUST HAVE A WORD AS SECOND ARGUMENT - ", arg2, 1, in) %return %finish %if fnval(arg1 >> 8) = 0 %then %start error("UNDEFINED PROCEDURE FOR ABBREV - ", arg1, 1, in) %return %finish ! SO ARG1 OK arg3 = fnval(arg2 >> 8) ! GET SPEC FOR ABBREVIATION %if arg3 = 0 %then -> transpec ! UNDEFINED SO OK %if arg3 & userpre = userpre %then %start redef = 1 newfn = fromlist(arg2, newfn) %unless newfn = nil -> transpec %finish ! ALREADY DEFINED BY USER error("YOU CANNOT USE ONE OF LOGOS OWN PROCEDURE NAMES" . " AS AN ABBREVIATION - ", arg2, 1, in) %return transpec: w1 = arg1 >> 8 w2 = arg2 >> 8 fnval(w2) = fnval(w1) fnparse(w2) = fnparse(w1) fnlen(w2) = fnlen(w1) fntext(w2) = fntext(w1) printel(arg2) prstring(" IS") %if redef = 1 %then prstring(" REDEFINED") %else prstring(" DEFINED") prstring(" AS AN ABBREVIATION FOR ") printel(arg1) nooline(1) stack(arg1) %return ! END ABBREV ! ! sysfun(100): !MFIRST arg1 = unstack arg2 = unstack %if arg1 & lm # lm %or arg1 = nil %then %start error("MFIRST MUST HAVE A NON-NULL LIST AS FIRST ARGUMENT -", %C arg1, 1, in) %return %finish %if (arg1 >> 8) >= lafnb %then %start ! LIST EMBEDDED IN FN DEFN error("LIST EMBEDDED IN PROCEDURE DEFN CANNOT BE UPDATED - ", %C arg1, 1, in) %return %finish rephead(arg1, arg2) stack(arg2) %return ! END MFIRST ! ! sysfun(101): !MBUTFIRST arg1 = unstack arg2 = unstack %if arg1 & lm # lm %or arg1 = nil %then %start error("MBUTFIRST MUST HAVE A NON EMPTY LIST AS FIRST ARGUMENT - ", arg1, 1, in) %return %finish %if (arg1 >> 8) >= lafnb %then %start error("LIST EMBEDDED IN PROCEDURE DEFN CANNOT BE UPDATED - ", %C arg1, 1, in) %return %finish %if arg2 & lm # lm %then %start error("MBUTFIRST MUST HAVE A LIST AS SECOND ARGUMENT - ", arg2, %C 1, in) %return %finish reptail(arg1, arg2) stack(arg2) %return ! END MBUTFIRST ! ! sysfun(102): !PACK arg1 = unstack %if arg1 & lm # lm %then %start error("PACK MUST HAVE A LIST AS ARGUMENT - ", arg1, 1, in) %return %finish wstr1 = "" %while arg1 # nil %cycle %if quitflag = 1 %then %start quitflag = 0 jumpout = 0 jumpflag = 1 stack(quit) %return %finish %if holdflag = 1 %then %start holdflag = 0 stksys(arg1) error("USER INTERRUPT", empty, 0, in) arg1 = unstksys %if jumpflag = 1 %then %return %finish arg2 = hd(arg1) %if arg2 & nm = nm %then %start arg3 = arg2 >> 8 %if arg3 >= 0 %and arg3 <= 9 %then %start wstr2 = numtostr(arg2) -> packok %finish %finish %else %start %if arg2 & wm = wm %then %start wstr2 = wa(arg2 >> 8) %if length(wstr2) = 1 %then -> packok %finish %finish error("CAN ONLY PACK SINGLE LETTERS OR DIGITS - ", arg2, 1, in) %return packok: %if length(wstr1) = 64 %then %start error("WORD LENGTH EXCEEDED - ", arg1, 1, in) %return %finish wstr1 = wstr1 . wstr2 arg1 = tl(arg1) %repeat stack(put(wstr1)) %return !END PACK ! ! sysfun(103): !UNPACK arg1 = unstack %if arg1 & lm = lm %then %start error("UNPACK MUST HAVE A WORD OR NUMBER AS ARGUMENT - ", arg1, %C 1, in) %return %finish %if arg1 & nm = nm %then wstr1 = numtostr(arg1) %C %else wstr1 = wa(arg1 >> 8) arg1 = nil arg2 = length(wstr1) %while arg2 # 0 %cycle w1 = put(fromstring(wstr1, arg2, arg2)) arg1 = cons(w1, arg1) arg2 = arg2 - 1 %repeat stack(arg1) %return !END UNPACK ! ! sysfun(104): !COMPRESS device = disc filetidy ! ASSUME USER IDENTIFIED %if jumpflag = 1 %then %return device = tty %unless cactfile = 2 %then getmaster stack(true) %return ! END COMPRESS ! ! sysfun(105): !GOODBYE device = disc filetidy %if jumpflag = 1 %then %return device = tty prstring("FILE TIDIED") nooline(1) closestream(1) clear("1") closesm(6) clear("6") destroy("T#LOGOSTK") %stop ! END GOODBYE ! ! sysfun(106): !EXIT closestream(1) clear("1") closesm(6) clear("6") destroy("T#LOGOSTK") %stop ! END EXIT ! ! sysfun(107): !AND arg2 = unstack arg1 = unstack stack(arg2) ! DISCARD FIRST ARG %return ! END AND ! ! sysfun(108): !QUOTE stack(quote) %return ! END QUOTE ! ! sysfun(109): !DOTS stack(dots) %return ! END DOTS ! ! sysfun(110): !IT stack(val) %return ! END IT ! ! sysfun(111): !VALUE arg1 = unstack %if arg1 & wm # wm %then %start error("VALUE OF WHAT? ", arg1, 1, in) %return %finish val1: arg2 = getval(arg1, envir) %if arg2 = undef %then %start stksys(arg1) error("NO VALUE HAS BEEN GIVEN TO VARIABLE - ", arg1, 0, in) arg1 = unstksys %if jumpflag = 1 %then %return -> val1 %finish stack(arg2) %return ! END VALUE ! ! sysfun(112): !REPEAT arg1 = unstack %if arg1 & nm # nm %or arg1 < 0 %then %start error("REPEAT NEEDS A NON-NEGATIVE NUMBER - ", arg1, 1, in) %return %finish %if arg1 >> 8 = 0 %then %start stack(arg1) %return %finish %cycle arg2 = 1, 1, arg1 >> 8 arg3 = in stksys(in) eval(arg3, eachval) in = unstksys %if jumpflag = 1 %then %return w1 = unstack ! LAST VALUE %repeat stack(w1) %return ! END REPEAT ! ! sysfun(113): !RESET logotime = time100 stack(logotime << 8 ! nm) %return ! END RESET ! ! sysfun(114): !TIME stack((time100 - logotime) << 8 ! nm) %return ! END TIME ! ! ! SYSFUN(115):; ! DOLOGO !ARG1=UNSTACK !%IF ARG1&LM#LM %THENSTART ! ERROR("DOLOGO MUST HAVE A LIST AS ARGUMENT - ",ARG1,1,IN) ! %RETURN ! %FINISH !STKSYS(IN) ! ! IN=UNSTKSYS ! STACK(UNSTACK) ! %RETURN; ! END DOLOGO ! ! sysfun(116): !RANDOM arg1 = unstack %if arg1 & nm # nm %then %start error("RANDOM MUST HAVE A NUMBER AS ARGUMENT - ", arg1, 1, in) %return %finish %if arg1 < 0 %then %start arg2 = -1 arg1 = -(arg1 >> 8 ! t8) + 1 ! POSITIVE BINARY +1 %finish %else %start arg2 = 1 arg1 = arg1 >> 8 + 1 %finish stack((intpt(random(ranseed, 1) * arg1) * arg2) << 8 ! nm) %return ! END RANDOM ! ! sysfun(117): !APPLY arg1 = unstack %if arg1 & wm # wm %then %start error("APPLY MUST HAVE A WORD AS FIRST ARG - ", arg1, 1, in) %return %finish %if arg1 = ift %or arg1 = iff %then %start in = cons(arg1 ! fnm, in) %finish %else %start %if arg1 = repeat %then %start %if in = nil %then %start error("NOT ENOUGH ARGS FOR ", arg1, 1, in) %return %finish arg2 = reverse(in) arg3 = hd(arg2) in = reverse(tl(arg2)) in = cons(arg3, cons(arg1 ! fnm, in)) %finish %else %start arg1 = cons(arg1 ! fnm, nil) %if in # nil %then %start %if (in >> 8) >= lafnb %then in = copy(in) ! COPY FROM FN SPACE arg2 = in %while tl(arg2) # nil %cycle arg2 = tl(arg2) %repeat reptail(arg2, arg1) %finish %else in = arg1 %finish %finish !IN=CONS(UNSTACK,IN) stksys(in) eval(in, eachval) in = unstksys ! STACK(UNSTACK) %return ! END APPLY ! ! sysfun(118): !ALERT list(masnum . "LOGALERT") stack(true) %return ! END ALERT ! ! ! sysfun(119): !EXERCISE %cycle arg1 = 1, 1, 8 %if status(masnum . tdevnames(arg1), 1) < 0 %then %start prstring("SYSTEM FILE " . tdevnames(arg1) . " NEEDS RESTORING.") nooline(1) prstring("SET PERMIT W,ALL AFTER RESTORE.") nooline(1) %finish %else disconnect(masnum . tdevnames(arg1)) %repeat %cycle arg1 = 1, 1, 2 %if status(masnum . sysfiles(arg1), 1) < 0 %then %start prstring("SYSTEM FILE " . sysfiles(arg1) . " NEEDS RESTORING.") nooline(1) prstring("SET PERMIT RS,ALL AFTER RESTORE.") nooline(1) %finish %else disconnect(masnum . sysfiles(arg1)) %repeat stack(true) %return ! END EXERCISE ! ! sysfun(120): !DUMP dump("USER REQUEST") stack(nil) %return ! END DUMP ! ! ! sysfun(122): !GETTY selectinput(0) closestream(3) clear("3") destroy("T#TEMP") prstring("TEMPORARY FILE DESTROYED") nooline(1) prstring("LOADED AND READY") nooline(3) stack(nil) %return ! END GETTY ! ! sysfun(123): !TRUE stack(true) %return ! END TRUE ! ! sysfun(124): !FALSE stack(false) %return ! END FALSE ! ! sysfun(125): !SPACE stack(space1) %return ! END SPACE ! ! sysfun(126): !TAB stack(tab) %return ! END TAB ! ! sysfun(127): !NL stack(enel) %return ! END NL ! ! sysfun(128): !EMPTY stack(empty) %return ! END EMPTY ! ! ! ! sysfun(131): !SETELIM arg1 = unstack %if arg1 & nm # nm %or arg1 < 0 %then %start error("SETELIM NEEDS A POSITIVE NUMBER - ", arg1, 1, in) %return %finish evalimit = arg1 >> 8 stack(arg1) %return ! END SETELIM ! ! sysfun(132): !SETCFLG clectflg = 1 stack(nil) %return ! END SETCFLG ! ! sysfun(133): !HASHINFO arg1 = hash1023 // hash1024 prstring(" AVERAGE NO OF ACCESSES OF WA= ") write(arg1, 6) nooline(1) prstring(" WHERE NO OF WORDS HASHED= ") write(hash1024, 8) nooline(1) prstring(" AND TOTAL NO OF ACCESSES OF WA= ") write(hash1023, 8) nooline(1) prstring(" DUMPING INFO TO FILE HASHINFO") nooline(1) selectoutput(1) %cycle arg1 = 0, 1, 1022 %unless wa(arg1) = "?" %then %start nooline(1) prstring(" ORIG HASH VALUE=") write(hashinfo(arg1), 5) prstring(" ACHIEVED ENTRY KEY=") write(arg1, 5) prstring(" WORD= ") prstring(wa(arg1)) %finish %repeat selectoutput(0) prstring(" FILE HASH INFO WRITTEN") nooline(1) stack(true) %return ! END HASHINFO ! ! sysfun(134): !MAKEASSOC arg1 = unstack ! OBJECT arg2 = unstack ! ATTRIBUTE arg3 = unstack ! VALUE %if arg1 & wm # wm %then %start error("MAKEASSOC MUST HAVE A WORD AS FIRST ARGUMENT - ", arg1, %C 1, in) %return %finish arg1 = arg1 >> 8 ! WA INDEX stack(arg3) arg3 = cons(arg2, cons(arg3, nil)) ! [ATT VAL] %if findass(assocwa(arg1), arg2) = nil %then %start ! NO EXISTING ASSOC assocwa(arg1) = cons(arg3, assocwa(arg1)) ! INSERT [ATT VAL] AS FIRST ELEMENT IN ASSLIST FOR THIS OBJECT %finish %else %start ! ASSOC ALREADY EXISTS. W2 POINTS TO LIST ! WHOSE HEAD IS ASSOC rephead(w2, arg3) %finish %return ! END MAKEASSOC ! ! sysfun(135): !GETASSOC arg1 = unstack ! OB arg2 = unstack ! ATT %if arg1 & wm # wm %then %start error("GETASSOC MUST HAVE A WORD AS FIRST ARGUMENT - ", arg1, 1, %C in) %return %finish arg3 = findass(assocwa(arg1 >> 8), arg2) %if arg3 # nil %then arg3 = hd(tl(hd(arg3))) ! VALUE stack(arg3) %return ! END GETASSOC ! ! sysfun(136): !REMASSOC arg1 = unstack arg2 = unstack %if arg1 & wm # wm %then %start error("REMASSOC MUST HAVE A WORD AS FIRST ARGUMENT - ", arg1, 1, %C in) %return %finish arg1 = arg1 >> 8 arg3 = findass(assocwa(arg1), arg2) %if arg3 # nil %then %start ! ASSOC EXISTS %if w1 = w2 %then assocwa(arg1) = tl(w2) %else reptail(w1, tl(w2)) %finish stack(nil) %return ! END REMASSOC ! ! sysfun(137): !CLEARASSOC arg1 = unstack %if arg1 & wm # wm %then %start error("CLEARASSOC MUST HAVE A WORD AS ARGUMENT - ", arg1, 1, in) %return %finish assocwa(arg1 >> 8) = nil stack(nil) %return ! END CLEARASSOC ! ! sysfun(138): !CLEARALLASSOC %cycle arg1 = 0, 1, 1022 assocwa(arg1) = nil %repeat stack(nil) %return ! END CLEARALLASSOC ! ! ! ! ! sysfun(144): !TRACE arg3 = unstack %if arg3 & wm = wm %then arg3 = cons(arg3, nil) %if arg3 & lm # lm %then %start error1("TRACE WHAT? ", arg3) -> tr2 %finish %while arg3 # nil %cycle %if quitflag = 1 %then %start quitflag = 0 jumpout = 0 jumpflag = 1 stack(quit) %return %finish %if holdflag = 1 %then %start holdflag = 0 stksys(arg3) error("USER INTERRUPT", empty, 0, in) arg3 = unstksys %if jumpflag = 1 %then %return %finish arg1 = hd(arg3) arg3 = tl(arg3) %if arg1 & wm # wm %then %start error1("TRACE WHAT? ", arg1) -> tr1 %finish arg2 = fnval(arg1 >> 8) %if arg2 = 0 %then %start error1("UNDEFINED PROCEDURE FOR TRACE - ", arg1) -> tr1 %finish %if arg2 & interp = interp %then %start error1("CANNOT TRACE AN INTERP PROCEDURE - ", arg1) -> tr1 %finish fnval(arg1 >> 8) = (arg2 & unmask) ! trace1 ! INSERT TRACE FLAG tr1: %repeat tr2: stack(true) %return ! END TRACE ! ! sysfun(145): !FULLTRACE arg3 = unstack %if arg3 & wm = wm %then arg3 = cons(arg3, nil) %if arg3 & lm # lm %then %start error1("FULLTRACE WHAT? ", arg3) -> ft2 %finish %while arg3 # nil %cycle %if quitflag = 1 %then %start quitflag = 0 jumpout = 0 jumpflag = 1 stack(quit) %return %finish %if holdflag = 1 %then %start holdflag = 0 stksys(arg3) error("USER INTERRUPT", empty, 0, in) arg3 = unstksys %if jumpflag = 1 %then %return %finish arg1 = hd(arg3) arg3 = tl(arg3) %if arg1 & wm # wm %then %start error1("FULLTRACE WHAT? ", arg1) -> ft1 %finish arg2 = fnval(arg1 >> 8) %if arg2 = 0 %then %start error1("UNDEFINED PROCEDURE FOR TRACE - ", arg1) -> ft1 %finish %if arg2 & interp = interp %then %start error1("CANNOT TRACE AN INTERP PROCEDURE - ", arg1) -> ft1 %finish fnval(arg1 >> 8) = (arg2 & unmask) ! trace2 !INSERT TRACE FLAG ft1: %repeat ft2: stack(true) %return ! END FULLTRACE ! ! ! sysfun(147): !UNTRACE arg3 = unstack nooline(1) %if arg3 & wm = wm %then arg3 = cons(arg3, nil) %if arg3 & lm # lm %then %start error1("UNTRACE WHAT? ", arg3) -> untr2 %finish %while arg3 # nil %cycle %if quitflag = 1 %then %start quitflag = 0 jumpout = 0 jumpflag = 1 stack(quit) %return %finish %if holdflag = 1 %then %start holdflag = 0 stksys(arg3) error("USER INTERRUPT", empty, 0, in) arg3 = unstksys %if jumpflag = 1 %then %return %finish arg1 = hd(arg3) arg3 = tl(arg3) %if arg1 & wm # wm %then %start error1("UNTRACE WHAT? ", arg1) -> untr1 %finish arg2 = fnval(arg1 >> 8) %if arg2 = 0 %then %start error1("UNDEFINED PROCEDURE FOR UNTRACE - ", arg1) -> untr1 %finish fnval(arg1 >> 8) = arg2 & unmask ! REMOVE TRACE FLAG. IF SYSFUN NO EFFECT untr1: %repeat untr2: stack(false) %return ! END UNTRACE ! ! sysfun(148): !MAPLIST arg1 = unstack %if arg1 & lm # lm %then %start error("MAPLIST MUST HAVE A LIST AS FIRST ARGUMENT - ", arg1, 1, in) %return %finish arg3 = nil arg2 = in %if hd(arg2) & nm = nm %then %start error("INVALID SECOND ARG FOR MAPLIST-", arg2, 1, in) %return %finish %if hd(arg2) & wm = wm %then %start stksys(in) stksys(arg1) eval(arg2, eachval) arg1 = unstksys in = unstksys %if jumpflag = 1 %then %return arg2 = unstack %finish %if arg2 & wm = wm %then %start %while arg1 # nil %cycle w1 = hd(arg1) ! qu w1 = cons(w1, cons(arg2 ! fnm, nil)) arg1 = tl(arg1) stksys(in) stksys(arg1) stksys(arg3) eval(w1, eachval) arg3 = unstksys arg1 = unstksys in = unstksys %if jumpflag = 1 %then %return arg3 = cons(unstack, arg3) %repeat %finish %else %start %if arg2 & lm # lm %then %start error("INVALID 2ND ARG FOR MAPLIST - ", arg2, 1, in) %return %finish %if hd(arg2) & lp # lp %then %start savedev = device device = srce sindex = sourceptr printlist(arg2 & X'FFFFFF0F') readinline(promp) device = savedev arg2 = parseline(0) %finish %while arg1 # nil %cycle w1 = hd(arg1) arg1 = tl(arg1) stksys(in) stksys(arg1) stksys(arg2) stksys(arg3) eval(arg2, w1) arg3 = unstksys arg2 = unstksys arg1 = unstksys in = unstksys %if jumpflag = 1 %then %return arg3 = cons(unstack, arg3) %repeat %finish %while arg3 # nil %cycle ! REVERSE LIST arg1 = cons(hd(arg3), arg1) arg3 = tl(arg3) %repeat stack(arg1) %return ! END MAPLIST ! ! sysfun(149): !APPLIST arg1 = unstack %if arg1 & lm # lm %then %start error("APPLIST MUST HAVE A LIST AS FIRST ARGUMENT - ", arg1, 1, in) %return %finish arg3 = nil arg2 = in %if hd(arg2) & nm = nm %then %start error("INVALID SECOND ARG FOR APPLIST-", arg2, 1, in) %return %finish %if hd(arg2) & wm = wm %then %start stksys(in) stksys(arg1) eval(arg2, eachval) arg1 = unstksys in = unstksys %if jumpflag = 1 %then %return arg2 = unstack %finish %if arg2 & wm = wm %then %start %while arg1 # nil %cycle w1 = hd(arg1) ! qu arg3 = cons(w1, cons(arg2 ! fnm, nil)) arg1 = tl(arg1) stksys(in) stksys(arg1) eval(arg3, eachval) arg1 = unstksys in = unstksys %if jumpflag = 1 %then %return arg3 = unstack %repeat %finish %else %start %if arg2 & lm # lm %then %start error("INVALID 2ND ARG FOR APPLIST - ", arg2, 1, in) %return %finish %if hd(arg2) & lp # lp %then %start savedev = device device = srce sindex = sourceptr printlist(arg2 & X'FFFFFF0F') readinline(promp) device = savedev arg2 = parseline(0) %finish %while arg1 # nil %cycle w1 = hd(arg1) arg1 = tl(arg1) stksys(in) stksys(arg1) stksys(arg2) eval(arg2, w1) arg2 = unstksys arg1 = unstksys in = unstksys %if jumpflag = 1 %then %return arg3 = unstack %repeat %finish stack(arg3) %return ! END APPLIST ! ! sysfun(150): !EACH %if eachval = undef %C %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 %then %start %if w1 = w2 %then assocwa(arg1) = tl(w2) %C %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 %then %start %if w1 = w2 %then assocwa(arg1) = tl(w2) %C %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 %then %start %if w1 = w2 %then assocwa(arg1) = tl(w2) %C %else reptail(w1, tl(w2)) %finish %repeat setupinf stack(nil) %return ! END CLEARDATABASE ! ! sysfun(152): !ASSERT arg1 = unstack %if arg1 & lm # lm %or arg1 = nil %then %start error("INVALID ARG FOR ASSERT -", arg1, 1, in) %return %finish %if hd(arg1) = implies %then addrule(arg1, 0, implinks) %else %start %if hd(arg1) = toinfer %then addrule(arg1, 0, inflinks) %C %else addfact(arg1, 0) %finish %if jumpflag = 1 %then %return stack(nil) %return ! END ASSERT ! ! sysfun(153): !AMONGQ arg1 = unstack arg2 = unstack %if arg2 & lm # lm %then %start 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 %then %start error("INVALID ARG FOR ISQ -", arg1, 1, in) %return %finish arg3 = undef stack(deduceq(arg1, 0)) %return ! END ISQ ! ! sysfun(155): !FINDANY arg1 = unstack arg2 = unstack %if arg1 & lm # lm %or arg1 = nil %then %start error("INVALID 1ST ARG FOR FINDANY -", arg1, 1, in) %return %finish %if arg2 & lm # lm %or arg2 = nil %then %start error("INVALID 2ND ARG FOR FINDANY -", arg2, 1, in) %return %finish arg3 = undef arg3 = deduceq(arg2, 0) %if jumpflag = 1 %then stack(arg2) %and %return %if arg3 = true %then stack(bindings(arg1)) %else stack(nil) %return ! END FINDANY ! ! sysfun(156): !FINDALL arg1 = unstack arg2 = unstack %if arg1 & lm # lm %or arg1 = nil %then %start error("INVALID 1ST ARG FOR FINDALL -", arg1, 1, in) %return %finish %if arg2 & lm # lm %or arg2 = nil %then %start error("INVALID 2ND ARG FOR FINDALL -", arg2, 1, in) %return %finish arg3 = nil arg2 = deduceq(arg2, 0) %if jumpflag = 1 %then stack(arg2) %else stack(arg3) %return !END FINDALL ! ! ! sysfun(160): !FORWARD arg1 = chdevarg %if jumpflag = 1 %then stack(arg1) %and %return -> 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 %then %return coordok(intpt(yturtle + dy)) %if jumpflag = 1 %then %return %if penturtle = down %then %start binarg(1, 0) binarg(2, 4) sendbin(0, 2) ! PENDOWN %finish binarg(1, 2) binarg(2, intpt(dx + fracpt(xturtle)) << 5) binarg(3, intpt(dy + fracpt(yturtle)) << 5) sendbin(0, 3) ! OUTLINV(DX,DY) %if penturtle = down %then %start binarg(1, 0) binarg(2, 0) sendbin(0, 2) ! PENUP %finish xturtle = xturtle + dx yturtle = yturtle + dy stack(w1) ! NO SPECIAL RESULT %return ! fdsw(3): !DISPLAY dy = arg1 * sin(hdturtle / 57.3) dx = arg1 * cos(hdturtle / 57.3) coordok(intpt(xturtle + dx)) %if jumpflag = 1 %then %return coordok(intpt(yturtle + dy)) %if jumpflag = 1 %then %return binarg(2, intpt(dx + fracpt(xturtle)) << 5) binarg(3, intpt(dy + fracpt(yturtle)) << 5) %if penturtle = down %then binarg(1, 9) %else binarg(1, 5) sendbin(0, 3) ! DLINEV(DX,DY) OR DSETV(DX,DY) xturtle = xturtle + dx yturtle = yturtle + dy stack(w1) %return ! fdsw(4): !TURTLE %if arg1 = 0 %then stack(w1) %and %return dy = arg1 * sin(hdturtle / 57.3) dx = arg1 * cos(hdturtle / 57.3) %if arg1 < 0 %then tsend(bdbits, tscale(-arg1)) %C %else tsend(fdbits, tscale(arg1)) %if jumpflag = 1 %then %return xturtle = xturtle + dx yturtle = yturtle + dy stack(w1) %return ! fdsw(5): fdsw(6): fdsw(7): !PUNCH,MUSIC,MECCANO ! error("DEVICE CANNOT DO", fn, 1, in) %return fdsw(8): !GT42DISPLAY dx = arg1 * cos(hdturtle / 57.3) dy = arg1 * sin(hdturtle / 57.3) coordok(intpt(xturtle + dx)) %if jumpflag = 1 %then %return coordok(intpt(yturtle + dy)) %if jumpflag = 1 %then %return ! *** CHECK FOR COMPILING A PICTURE (LATER VERSION) vector(dx, dy) xturtle = xturtle + dx yturtle = yturtle + dy stack(w1) %return ! END FORWARD ! ! sysfun(161): !BACKWARD arg1 = chdevarg %if jumpflag = 1 %then stack(arg1) %and %return -> bdsw(tdev) ! bdsw(1): bdsw(2): !PLOTTERS arg1 = -arg1 -> fdsw(1) ! bdsw(3): !DISPLAY arg1 = -arg1 -> fdsw(3) ! bdsw(4): !TURTLE arg1 = -arg1 -> fdsw(4) ! bdsw(5): bdsw(6): bdsw(7): !PUNCH,MUSIC,MECCANO error("DEVICE CANNOT DO", fn, 1, in) ! %return bdsw(8): !GT42DISPLAA arg1 = -arg1 -> fdsw(8) ! END BACKWARD ! sysfun(162): !LEFT arg1 = chdevarg %if jumpflag = 1 %then stack(arg1) %and %return -> leftsw(tdev) ! leftsw(1): leftsw(2): !PLOTTERS %if arg1 = 0 %then stack(w1) %and %return hdturtle = mod360(hdturtle + arg1) %if arg1 < 0 %then pindsend(0, -arg1) %else pindsend(pindlbit, arg1) %if jumpflag = 1 %then %return %if w1 = true %then w1 = tstate stack(w1) %return ! leftsw(3): !DISPLAY hdturtle = mod360(hdturtle + arg1) %if w1 = true %then w1 = tstate stack(w1) %return ! leftsw(4): !TURTLE %if arg1 = 0 %then stack(w1) %and %return hdturtle = mod360(hdturtle + arg1) %if arg1 < 0 %then tsend(rtbits, tangle(-arg1)) %C %else tsend(ltbits, tangle(arg1)) %if jumpflag = 1 %then %return %if w1 = true %then w1 = tstate stack(w1) %return ! leftsw(5): leftsw(6): leftsw(7): !PUNCH,MUSIC,MECCANO error("DEVICE CANNOT DO", fn, 1, in) %return ! leftsw(8): !GT42DISPLAY hdturtle = mod360(hdturtle + arg1) calcturtle stack(w1) %return ! END LEFT ! ! sysfun(163): !RIGHT arg1 = chdevarg %if jumpflag = 1 %then stack(arg1) %and %return -> rightsw(tdev) ! rightsw(1): rightsw(2): !PLOTTERS arg1 = -arg1 -> leftsw(1) ! rightsw(3): !DISPLAY arg1 = -arg1 -> leftsw(3) ! rightsw(4): !TURTLE arg1 = -arg1 -> leftsw(4) ! rightsw(5): rightsw(6): rightsw(7): !PUNCH,MUSIC,MECCANO error("DEVICE CANNOT DO ", fn, 1, in) %return ! rightsw(8): !GT42DISPLAA arg1 = -arg1 -> leftsw(8) ! END RIGHT ! ! sysfun(164): !LIFTPEN -> liftsw(tdev) ! liftsw(1): liftsw(2): liftsw(3): liftsw(8): !PLOTTERSANDDISPLAYS penturtle = up stack(false) %return ! liftsw(4): !TURTLE penturtle = up tsend1(32) stack(false) %return ! liftsw(5): liftsw(6): liftsw(7): !PUNCH,MUSIC,MECCANO error("DEVICE CANNOT DO", fn, 1, in) %return ! END LIFT ! ! sysfun(165): !DROPPEN -> dropsw(tdev) ! dropsw(1): dropsw(2): dropsw(3): dropsw(8): !PLOTTERSANDDISPLAYS penturtle = down stack(true) %return ! dropsw(4): !TURTLE penturtle = down tsend1(32) stack(true) %return ! dropsw(5): dropsw(6): dropsw(7): !PUNCH,MUSIC,MECCANO error("DEVICE CANNOT DO", fn, 1, in) %return ! END DROP ! ! sysfun(166): !HOOT -> hootsw(tdev) ! hootsw(1): hootsw(2): hootsw(3): hootsw(5): hootsw(6): hootsw(7): !ALLBUTTURTLE error("DEVICE CANNOT DO ", fn, 1, in) %return ! hootsw(4): !TURTLE tsend1(hootbit) stack(true) %return ! hootsw(8): !GT42DISPLAY set42(chpic) ch3(bleep) stack(true) %return ! END HOOT ! ! sysfun(167): !CENTRE -> censw(tdev) ! censw(1): censw(2): !PLOTTERS xturtle = 0 yturtle = 0 hdturtle = 0 penturtle = down binarg(1, 1) binarg(2, 0) binarg(3, 0) sendbin(0, 3) ! OUTLIN(0,0) pindsend(pindrbit + pindlbit, 360) ! RESET IND ANTICLOCK %if jumpflag = 1 %then %return stack(true) %return ! censw(3): !DISPLAY xturtle = 0 yturtle = 0 hdturtle = 0 penturtle = down binarg(1, 6) binarg(2, 0) binarg(3, 0) sendbin(0, 3) ! DPOINT(0,0) stack(true) %return ! censw(4): !TURTLE arg2 = 0 arg3 = 0 w2 = 0 arg1 = down w1 = true -> posw(4) ! SETTURTLE ! censw(5): censw(6): censw(7): !PUNCH,MUSIC,MECCANO error("DEVICE CANNOT DO", fn, 1, in) %return ! censw(8): !GT42DISPLAY xturtle = 0 yturtle = 0 hdturtle = 0 penturtle = down point(512, 512) calcturtle stack(true) %return ! END CENTRE ! ! sysfun(168): !CLEAR -> clsw(tdev) ! clsw(1): clsw(2): clsw(4): !PLOTTERS,TURTLE stack(true) %return ! clsw(5): clsw(6): clsw(7): !PUNCH,MUSIC,MECCANO error("DEVICE CANNOT DO", fn, 1, in) %return ! clsw(3): !DISPLAY binarg(1, 0) sendbin(0, 1) ! CLEARDIS -> whsw(3) ! clsw(8): !GT42DISPLAY set42(chpic) clear42 xturtle = 0 yturtle = 0 hdturtle = 0 penturtle = down point(512, 512) -> whsw(8) ! END CLEAR ! ! sysfun(169): !WHERE -> whsw(tdev) ! whsw(1): whsw(2): !PLOTTERS arg1 = hdturtle + 90 binarg(1, 0) binarg(2, 4) sendbin(0, 2) ! PENDOWN %cycle w1 = 1, 1, 2 arg1 = mod360(arg1 + 60) arg2 = int(10.0 * sin(arg1 / 57.3)) arg3 = int(10.0 * cos(arg1 / 57.3)) binarg(1, 2) binarg(2, arg3 << 5) binarg(3, arg2 << 5) sendbin(0, 3) ! OUTLINV(DX,DY) binarg(2, -(arg3 << 5)) binarg(3, -(arg2 << 5)) sendbin(0, 3) ! OUTLINV(-DX,-DY) %repeat binarg(1, 0) binarg(2, 0) sendbin(0, 2) ! PENUP stack(true) %return ! whsw(3): !DISPLAY rw1 = sin(hdturtle / 57.3) rw2 = cos(hdturtle / 57.3) binarg(1, 12) binarg(2, int(-1300.0 * (0.9659 * rw2 + 0.2588 * rw1))) binarg(3, int(-1300.0 * (0.9659 * rw1 - 0.2588 * rw2))) binarg(4, int(0.5176 * 1300.0 * rw1)) binarg(5, int(-0.5176 * 1300.0 * rw2)) sendbin(0, 5) ! DRAWTURT stack(true) %return ! whsw(4): whsw(5): whsw(6): whsw(7): !TURTLE,PUNCH,MUSIC,MECCANO error("DEVICE CANNOT DO", fn, 1, in) %return ! whsw(8): !GT42DISPLAY showturtle42 = 1 calcturtle stack(true) %return ! END WHERE ! ! sysfun(170): !HERE -> heresw(tdev) ! heresw(1): heresw(2): heresw(3): heresw(4): heresw(8): !PLOTTERS,DISPLAY,TURTLE stack(tstate) %return ! heresw(5): heresw(6): heresw(7): !PUNCH,MUSIC,MECCANO error("DEVICE CANNOT DO", fn, 1, in) %return ! END HERE ! ! sysfun(171): !XCOR -> xcorsw(tdev) ! xcorsw(1): xcorsw(2): xcorsw(3): xcorsw(4): xcorsw(8): !PLOTTERS,DISPLAY,TURTLE stack(intpt(xturtle) << 8 ! nm) %return ! xcorsw(5): xcorsw(6): xcorsw(7): !PUNCH,MUSIC,MECCANO error("DEVICE CANNOT DO ", fn, 1, in) %return ! END XCOR ! ! sysfun(172): !YCOR -> ycorsw(tdev) ! ycorsw(1): ycorsw(2): ycorsw(3): ycorsw(4): ycorsw(8): !PLOTTERS,DISPLAY,TURTLE stack(intpt(yturtle) << 8 ! nm) %return ! ycorsw(5): ycorsw(6): ycorsw(7): !PUNCH,MUSIC,MECCANO error("DEVICE CANNOT DO ", fn, 1, in) %return ! END YCOE ! ! sysfun(173): !HEADING -> hdsw(tdev) ! hdsw(1): hdsw(2): hdsw(3): hdsw(4): hdsw(8): !PLOTTERS,DISPLAY,TURTLE stack(hdturtle << 8 ! nm) %return ! hdsw(5): hdsw(6): hdsw(7): !PUNCH,MUSIC,MECCANO error("DEVICE CANNOT DO ", fn, 1, in) %return ! END HEADING ! ! sysfun(174): !PEN -> pensw(tdev) ! pensw(1): pensw(2): pensw(3): pensw(4): pensw(8): !PLOTTERS,DISPLAY,TURTLE stack(penturtle) %return ! pensw(5): pensw(6): pensw(7): !PUNCH,MUSIC,MECCANO error("DEVICE CANNOT DO ", fn, 1, in) %return ! END PEN ! ! sysfun(175): !SETX arg1 = chdevarg %if jumpflag = 1 %then stack(arg1) %and %return -> setxsw(tdev) ! setxsw(1): setxsw(2): !PLOTTERS coordok(arg1) %if jumpflag = 1 %then %return xturtle = arg1 binarg(1, 1) binarg(2, arg1 << 5) binarg(3, intpt(yturtle) << 5) sendbin(0, 3) ! OUTLIN(X,Y) stack(w1) %return ! setxsw(3): !DISPLAY coordok(arg1) %if jumpflag = 1 %then %return xturtle = arg1 %if penturtle = down %then binarg(1, 6) %else binarg(1, 4) ! EITHER DPOINT(X,Y) OR DSET(X,Y) binarg(2, arg1 << 5) binarg(3, intpt(yturtle) << 5) sendbin(0, 3) stack(w1) %return ! setxsw(4): !TURTLE setup(arg1 - intpt(xturtle), hdturtle) %if jumpflag = 1 %then %return xturtle = arg1 stack(w1) %return ! setxsw(5): setxsw(6): setxsw(7): !PUNCH,MUSIC,MECCANO error("DEVICE CANNOT DO ", fn, 1, in) %return ! setxsw(8): !GT42DISPLAY coordok(arg1) %if jumpflag = 1 %then %return xturtle = arg1 point(xturtle + 512, yturtle + 512) stack(w1) %return ! END SETX ! ! sysfun(176): !SETY arg1 = chdevarg %if jumpflag = 1 %then stack(arg1) %and %return -> setysw(tdev) ! setysw(1): setysw(2): !PLOTTERS coordok(arg1) %if jumpflag = 1 %then %return yturtle = arg1 binarg(1, 1) binarg(2, intpt(xturtle) << 5) binarg(3, arg1 << 5) sendbin(0, 3) ! OUTLIN,X,Y) stack(w1) %return ! setysw(3): !DISPLAY coordok(arg1) %if jumpflag = 1 %then %return yturtle = arg1 %if penturtle = down %then binarg(1, 6) %else binarg(1, 4) binarg(2, intpt(xturtle) << 5) binarg(3, arg1 << 5) sendbin(0, 3) stack(w1) %return ! setysw(4): !TURTLE setup(arg1 - intpt(yturtle), hdturtle - 90) %if jumpflag = 1 %then %return yturtle = arg1 stack(w1) %return ! setysw(5): setysw(6): setysw(7): !PUNCH,MUSIC,MECCANO error("DEVICE CANNOT DO ", fn, 1, in) %return ! setysw(8): !GT42DISPLAY coordok(arg1) %if jumpflag = 1 %then %return yturtle = arg1 point(xturtle + 512, yturtle + 512) stack(w1) %return ! END SETY ! ! sysfun(177): !SETHEADING arg1 = chdevarg %if jumpflag = 1 %then stack(arg1) %and %return -> sethsw(tdev) ! sethsw(1): sethsw(2): !PLOTTERS arg1 = mod360(arg1 - hdturtle) %if arg1 > 180 %then arg1 = arg1 - 360 -> leftsw(1) ! sethsw(3): !DISPLAY hdturtle = mod360(arg1) stack(w1) %return ! sethsw(4): !TURTLE arg1 = mod360(arg1 - hdturtle) %if arg1 > 180 %then arg1 = arg1 - 360 -> leftsw(4) ! sethsw(5): sethsw(6): sethsw(7): !PUNCH,MUSIC,MECCANO error("DEVICE CANNOT DO ", fn, 1, in) %return ! sethsw(8): !GT42DISPLAY hdturtle = mod360(arg1) calcturtle stack(w1) %return ! END SETHEADING ! ! sysfun(178): !POSITION arg1 = unstack %if arg1 & lm = 0 %then %start error("LIST INPUT REQUIRED FOR ", fn, 1, in) %return %finish w1 = arg1 %if listlen(arg1) # 4 %then -> pos1 arg2 = hd(arg1) arg1 = tl(arg1) ! X arg3 = hd(arg1) arg1 = tl(arg1) ! Y w2 = hd(arg1) ! HEADING arg1 = hd(tl(arg1)) ! PEN %if arg2 & nm = 0 %or arg3 & nm = 0 %or w2 & nm = 0 %or (arg1 # up %C %and arg1 # down) %then -> pos1 arg2 = impnum(arg2) arg3 = impnum(arg3) w2 = impnum(w2) -> posw(tdev) ! posw(1): posw(2): !PLOTTERS coordok(arg2) %if jumpflag = 1 %then %return coordok(arg3) %if jumpflag = 1 %then %return xturtle = arg2 yturtle = arg3 penturtle = arg1 binarg(1, 1) binarg(2, arg2 << 5) binarg(3, arg3 << 5) sendbin(0, 3) ! OUTLIN(X,Y) arg1 = w2 -> sethsw(1) pos1: error("WRONGLY FORMATTED LIST FOR ", fn, 1, in) %return ! posw(3): !DISPLAY coordok(arg2) %if jumpflag = 1 %then %return coordok(arg3) %if jumpflag = 1 %then %return xturtle = arg2 yturtle = arg3 hdturtle = mod360(w2) penturtle = arg1 %if penturtle = down %then binarg(1, 6) %else binarg(1, 4) binarg(2, arg2 << 5) binarg(3, arg3 << 5) sendbin(0, 3) stack(w1) %return ! posw(4): !TURTLE penturtle = up tsend1(32) ! PENUP setup(arg2 - intpt(xturtle), hdturtle) %if jumpflag = 1 %then %return setup(arg3 - intpt(yturtle), hdturtle - 90) %if jumpflag = 1 %then %return xturtle = arg2 yturtle = arg3 arg2 = mod360(w2 - hdturtle) hdturtle = mod360(w2) %if arg2 > 180 %then arg2 = arg2 - 360 %if arg2 # 0 %then %start %if arg2 < 0 %then tsend(rtbits, tangle(-arg2)) %C %else tsend(ltbits, tangle(arg2)) %if jumpflag = 1 %then %return %finish penturtle = arg1 tsend1(32) stack(w1) %return ! posw(5): posw(6): posw(7): !PUNCH,MUSIC,MECCANO error("DEVICE CANNOT DO ", fn, 1, in) %return ! posw(8): !GT42DISPLAY coordok(arg2) %if jumpflag = 1 %then %return coordok(arg3) %if jumpflag = 1 %then %return xturtle = arg2 yturtle = arg3 hdturtle = mod360(w1) penturtle = w2 point(xturtle + 512, yturtle + 512) calcturtle stack(w1) %return ! END POSITION ! ! sysfun(179): !ARCLEFT arg1 = chdevarg %if jumpflag = 1 %then stack(arg1) %and %return arg2 = chdevarg %if jumpflag = 1 %then stack(arg2) %and %return arg3 = 0 ! TO INDICATE LEFT ! ARG1=ANG,ARG2=RAD w1 = true -> arclsw(tdev) ! arclsw(1): arclsw(2): !PLOTTERS %if arg1 = 0 %then -> arcl1 %if arg2 = 0 %then -> leftsw(1) ! ZERO RAD. DO LEFT(ANG) xc = int(-arg2 * sin(hdturtle / 57.3) * 32) yc = int(arg2 * cos(hdturtle / 57.3) * 32) rw1 = 2.0 * arg2 * sin(arg1 / 114.6) dx = rw1 * cos((hdturtle + arg1 / 2.0) / 57.3) dy = rw1 * sin((hdturtle + arg1 / 2.0) / 57.3) circletest(arg3, arg2, arg1) %if jumpflag = 1 %then %return w1 = int(0.5 * mod(arg2) * arg1 / 360.0 * 32) %if penturtle = down %then %start binarg(1, 0) binarg(2, 4) sendbin(0, 2) ! PENDOWN %finish %if w1 # 0 %then %start binarg(1, 4) binarg(2, xc) binarg(3, yc) binarg(4, w1) sendbin(0, 4) ! OUTCRCLV(XC,YC,W1) %finish xturtle = xturtle + dx yturtle = yturtle + dy binarg(1, 1) binarg(2, intpt(xturtle) << 5) binarg(3, intpt(yturtle) << 5) ! OUTLIN(X,Y) TO FINISH sendbin(0, 3) %if penturtle = down %then %start binarg(1, 0) binarg(2, 0) sendbin(0, 2) %finish w1 = true -> leftsw(1) ! TO DO HDTURTLE AND INDICATOR arcl1: stack(tstate) %return ! arclsw(3): !DISPLAY %if arg1 = 0 %then -> arcl2 %if arg2 = 0 %then -> leftsw(3) xc = int(-arg2 * sin(hdturtle / 57.3) * 32) yc = int(arg2 * cos(hdturtle / 57.3) * 32) rw1 = 2.0 * arg2 * sin(arg1 / 114.6) dx = rw1 * cos((hdturtle + arg1 / 2.0) / 57.3) dy = rw1 * sin((hdturtle + arg1 / 2.0) / 57.3) circletest(arg3, arg2, arg1) %if jumpflag = 1 %then %return w1 = int(0.5 * mod(arg2) * arg1 / 360.0 * 32) %if penturtle = down %and w1 # 0 %then %start binarg(1, 11) binarg(2, xc) binarg(3, yc) binarg(4, w1) sendbin(0, 4) ! DCIRCLV(XC,YX,W1) %finish %else %start binarg(1, 5) binarg(2, intpt(dx + fracpt(xturtle)) << 5) binarg(3, intpt(dy + fracpt(yturtle)) << 5) sendbin(0, 3) ! DSETV(DX,DY) %finish xturtle = xturtle + dx yturtle = yturtle + dy hdturtle = mod360(hdturtle + arg1) arcl2: %if penturtle = down %then binarg(1, 6) %else binarg(1, 4) binarg(2, intpt(xturtle) << 5) binarg(3, intpt(yturtle) << 5) sendbin(0, 3) ! DPOINT OR DSET TO FINISH stack(tstate) %return ! arclsw(4): !TURTLE %if arg1 = 0 %then stack(tstate) %and %return %if arg2 = 0 %then -> leftsw(4) tarcleft(arg2, arg1) %if jumpflag = 1 %then %return stack(tstate) %return ! arclsw(5): arclsw(6): arclsw(7): !PUNCH,MUSIC,MECCANO error("DEVICE CANNOT DO ", fn, 1, in) %return ! arclsw(8): !GT42 %if arg1 = 0 %then stack(tstate) %and %return %if arg2 = 0 %then -> leftsw(8) gtarcleft(arg2, arg1) %if jumpflag = 1 %then %return stack(tstate) %return ! END ARCLEFT ! ! sysfun(180): !ARCRIGHT arg1 = chdevarg %if jumpflag = 1 %then stack(arg1) %and %return arg2 = chdevarg %if jumpflag = 1 %then stack(arg2) %and %return arg3 = 1 ! TO INDICATE RIGHT ! ARG1=ANG,ARG2=RAD w1 = true -> arcrsw(tdev) ! arcrsw(1): arcrsw(2): !PLOTTERS arg2 = -arg2 arg1 = -arg1 -> arclsw(1) ! arcrsw(3): !DISPLAY arg2 = -arg2 arg1 = -arg1 -> arclsw(3) ! arcrsw(4): !TURTLE arg2 = -arg2 -> arclsw(4) ! arcrsw(5): arcrsw(6): arcrsw(7): !PUNCH,MUSIC,MECCANO error("DEVICE CANNOT DO ", fn, 1, in) %return ! arcrsw(8): !GT42 arg2 = -arg2 -> arclsw(8) ! END ARCRIGHT ! ! sysfun(181): !PUNCH -> pnsw(tdev) ! pnsw(1): pnsw(2): pnsw(3): pnsw(4): pnsw(6): pnsw(7): pnsw(8): ! ALL BUT PUNCH error("DEVICE CANNOT DO ", fn, 1, in) %return ! pnsw(5): !PUNCH arg1 = chdevarg %if arg1 = err %then %return %if arg1 > 255 %then %start error("NUMBER TOO BIG TO BE PUNCHED", empty, 1, in) %return %finish %if arg1 < 0 %then %start error("NEGATIVE NUMBERS CANNOT BE PUNCHED", empty, 1, in) %return %finish binarg(1, 0) binarg(2, arg1) sendbin(0, 2) ! PUNCH(ARG1) stack(true) %return ! END PUNCH ! ! sysfun(182): !RUNOUT -> rnsw(tdev) ! rnsw(1): rnsw(2): rnsw(3): rnsw(4): rnsw(6): rnsw(7): rnsw(8): ! ALL BUT PUNCH error("DEVICE CANNOT DO ", fn, 1, in) %return ! rnsw(5): !PUNCH binarg(1, 1) sendbin(0, 1) ! RUNOUT stack(true) %return ! END RUNOUT ! ! ! fdsw(0): bdsw(0): leftsw(0): rightsw(0): liftsw(0): dropsw(0): hootsw(0): censw(0): clsw(0): whsw(0): heresw(0): xcorsw(0): ycorsw(0): hdsw(0): pensw(0): setxsw(0): setysw(0): sethsw(0): posw(0): arclsw(0): arcrsw(0): pnsw(0): rnsw(0): notesw(0): playsw(0): motasw(0): motbsw(0): rotsw(0): pairsw(0): error("NO TURTLE DEVICE ASSIGNED TO DO ", fn, 1, in) %return ! ! ! sysfun(183): !PLOTTERA claimdevice(1) %if jumpflag = 1 %then %return -> censw(1) ! END PLOTTERA ! ! sysfun(184): !PLOTTERB claimdevice(2) %if jumpflag = 1 %then %return -> censw(2) ! END PLOTTERB ! ! sysfun(185): !DISPLAY claimdevice(3) %if jumpflag = 1 %then %return binarg(1, 0) sendbin(0, 1) ! CLEARDIS -> censw(3) ! END DISPLAY ! ! sysfun(186): !TURTLE claimdevice(4) %if jumpflag = 1 %then %return xturtle = 0 yturtle = 0 hdturtle = 0 penturtle = down tsend1(32) ! PUT PEN DOWN stack(true) %return ! END TURTLE ! ! sysfun(187): !TAPE claimdevice(5) %if jumpflag = 1 %then %return -> rnsw(5) ! END TAPE ! ! sysfun(188): !FREE %if tdev = 0 %then %start error("YOU ARE NOT CONNECTED TO ANY DEVICE", empty, 1, in) %return %finish wstr1 = tdevnames(tdev) %if tdev = 8 %then disconnect(masnum . "EXEC26") freedevice prstring(wstr1 . " DISCONNECTED") nooline(1) stack(true) %return ! END FREE ! ! sysfun(189): !CLESET %if tdev = 0 %then %start error("DEVICE CANNOT DO ", fn, 1, in) %return %finish cleset stack(true) %return ! END CLESET ! ! ! ! sysfun(191): !MUSIC claimdevice(6) %if jumpflag = 1 %then %return stack(true) %return ! END MUSIC ! ! sysfun(192): !MECCANO claimdevice(7) %if jumpflag = 1 %then %return xturtle = 0 yturtle = 0 hdturtle = 0 penturtle = down stack(true) %return ! END MECCANO ! ! ! ! ! sysfun(200): !GT42 claimdevice(8) %if jumpflag = 1 %then %return load42(gt42exec) modifyexec clear42 point(512, 512) graphp = initgraphp picturepointer = corebottom set42(chtxt) hdturtle = 0 xturtle = 0 yturtle = 0 penturtle = down stack(true) %return ! END GT42 ! ! sysfun(201): !HIDE(HIDETURTLEFORGT42???) %if tdev # 8 %then error("DEVICE CANNOT DO ", fn, 1, in) %and %return hideturtle stack(true) %return ! END HIDE ! ! ! ! ! sysfun(210): !PICTURE/PIC %if tdev # 8 %then error("DEVICE CANNOT DO ", fn, 1, in) %and %return arg1 = unstack %if arg1 & wm # wm %C %then error("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 defpicture = 1 ! SET COMPILE FLAG stksys(in) eval(in, eachval) ! AND EXECUTE DRAWING FN in = unstksys %if jumpflag = 1 %then defpicture = 0 %and %return 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) defpicture = 0 ! RESET MARKER stack(tstate) !RETURN PIC NAME AS RESULT %return ! ! ! ! ! %return sysfun(211): !INCLUDE/INC %if tdev # 8 %C %then error("YOU NEED THE GT42 TO RUN MOVIES ", empty, 1, %C in) %and %C %return %if frameflag = 0 %C %then error("YOU ARE NOT INSIDE A FRAME ", empty, 1, in) %and %C %return arg1 = unstack ! GET NAME %if arg1 & wm # wm %C %then error("INCLUDE NEEDS A WORD ARGUMENT-", arg1, 1, in) %and %C %return w1 = arg1 >> 8 %if index42(w1)_ptr = 0 %C %then error("PICTURE DOES NOT EXIST-", arg1, 1, in) %and %return %if index42(w1)_ptr42 = 0 %then inc(w1) !PICTURENOTALREADYIN !DUMP CODE TO INCLUDE PICTURE AT CURRENT CRANE COORDS !*** WHEN MOVIE IS RUN index42(w1)_mode = curmode curframe = consg(ycrane, consg(xcrane, consg(curmode, consg(3, %C consg(index42(w1)_ptr42, consg(setn, curframe)))))) index42(w1)_x = xcrane ! RECORD CURRENT COORDS index42(w1)_y = ycrane stack(true) %return ! END-- INCLUDE ! sysfun(212): !ACTION %if tdev # 8 %C %then error("YOU NEED THE GT42 TO RUN MOVIES", empty, 1, in) %and %C %return %if frameflag # 0 %C %then error("ACTION INSIDE FRAME INVALID", empty, 1, in) %and %C %return frameflag = 1 ! SET FRAME FLAG curframe = nil ! AND INITIALISE FRAMELIST savepromp = promp promp = "A:" prompt(promp) %if grablist = nil %start ! CRANE ONLY INITIALISED !TOCENTREWHENNOTHING !ISCURRENTLYGRABBED 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)_lastmovetime = frametime %repeat stack(true) %return ! sysfun(213): !CUT %if tdev # 8 %C %then error("YOU NEED THE GT42 TO RUN MOVIES", empty, 1, in) %and %C %return %if frameflag = 0 %C %then error("CUT OUTSIDE FRAME INVALID", empty, 1, in) %and %return frameflag = 0 ! END OF FRAME %if curframe = nil %then %start ! SPECIAL CASE -- !NULLFRAMEDECLAREDSOPAD !FOR"FRAMETIME"TIMEUNITS w2 = consg(wait, consg(frametime, nil)) curmovie = cons(w2, curmovie) promp = savepromp prompt(promp) stack(true) %return %finish %cycle w1 = 1, 1, frametime ! RESET MOVIE RECORD !"MOVIE RECORD"ISA !ATABLEOFLISTS movierecord(w1) = nil %repeat ! currentmovietime = 1 w1 = curframe %while w1 # nil %cycle arg1 = hd(w1) // 256 %if arg1 > 0 %and arg1 & cranemask = cranemark %start !MOVEGROUPFOUND,EG ![MARKDYDXPTRTOINDEX---] w1 = tl(w1) ! "POP" MARK w2 = hd(tl(tl(w1))) >> 8 !ANDGETPTRTOINDEX %if hd(w1) >> 8 = cranemark %C %then w4 = int(hd(tl(w1)) / index42(w2)_moved * frametime) %C %else %start ! COULD BE A "HOLD" MARK rw1 = sqrt((hd(w1) / 256.0) ** 2 + (hd(tl(w1)) / 256.0) ** 2) w4 = int(rw1 / index42(w2)_moved * frametime) !CALCULATETIMETHISMOVE !WILLTAKE.(=FRACTIONOF !OFTOTALDISTANCEMOVED* !TIMETAKENFORFRAME) %finish w4 = 1 %if w4 <= 0 w4 = frametime %if w4 > frametime wptr1 == index42(w2)_lastmovetime wptr1 = wptr1 - w4 wptr1 = 1 %if wptr1 <= 0 wptr1 = frametime %if wptr1 > frametime !WPTR1NOWPOINTSTOTHE !THEAPPROPRIATEMOVIE !RECORD %if hd(w1) >> 8 # cranemark %C %then movierecord(wptr1) = cons(hd(w1), cons(hd(tl(w1)), %C consg(w4, consg(index42(w2)_ptr42 + 2, consg(pmov, %C movierecord(wptr1)))))) !ADDCELLTOLIST! currentmovietime = wptr1 ! UPDATE CURRENT MOVIE !CLOCKSOTHATANYINCLUSIONS !OROMMISIONS !CANBEADDEDTO !THEAPPROPRIATEMOVIE !RECORD w1 = tl(tl(tl(w1))) ! POP CELL FROM LIST %finish %else %start arg1 = hd(w1) arg2 = movierecord(currentmovietime) lastput movierecord(currentmovietime) = 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 = frametime + 1 %cycle w2 = 0 ! NO OF OUTSTANDING TIME !INNCREMENTS w1 = w1 - 1 %and w2 = w2 + 1 %until w1 = 0 %C %or movierecord(w1) # nil ! FIND LENGTH OF NEXT WAIT %if w1 = 0 %then %start ! END OF FRAME curmovie = cons(reverse(curframe), curmovie) !ADDTOMOVIELIST stack(true) promp = savepromp prompt(promp) %return %finish arg2 = consg(w2, consg(wait, movierecord(w1))) !CURRENTTIMESLICEOF !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 %then %start ! GARBAGE COLLECT NEEDED %cycle w4 = 1, 1, w1 ! PUT REMAINING MOVIE RECORD !INTOCOLLECTABLESPACE stack(movierecord(w4)) %repeat stksys(in) stksys(val) ! SYSTEM SPACE collect(envir) val = unstksys in = unstksys ! RESTORE %cycle w4 = w1, -1, 1 movierecord(w4) = unstack %repeat %finish %repeat ! ! ! ! sysfun(214): !ROLLMOVIE/ROLL %if tdev # 8 %then error("DEVICE CANNOT DO ", fn, 1, in) %and %return %if frameflag # 0 %C %then error("CANNOT ROLL MOVIE INSIDE A FRAME", empty, 1, %C in) %and %C %return set42(chpic) ! *** TUURTLE IS SWITCHED OFF FOR DURATION OF MOVIE ! w4 = showturtle42 ! SAVE CURRENT SHOWN STATE %if w4 = 1 %then hideturtle lbr ! NEST COMMAND GROUP %cycle w1 = 0, 1, 1022 ! OMIT ANY CURRENTLY %if index42(w1)_ptr42 # 0 %start !INCLUDED PICTURES ch3(setn) ch3(index42(w1)_ptr42) ch3(2) ch3(djump) ch3(index42(w1)_faddr) ! OMIT GROUP %finish %repeat rbr ! AND CLOSE GROUP w1 = reverse(curmovie) stack(true) %cycle %if w1 = nil %start ! END OF MOVIE showturtle %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 %cycle ch3(hd(w3) // 256) w3 = tl(w3) %repeat rbr %repeat %return ! sysfun(215): !CRANEFORWARD(VERSION2 %if tdev # 8 %then error("DEVICE CANNOT DO ", fn, 1, in) %and %return arg1 = unstack %if arg1 & nm # nm %C %then error("CRANEFORWARD NEEDS A NUMBER-", arg1, 1, in) %and %C %return %if frameflag = 0 %C %then error("CRANE MOVEMENT OUTSIDE FRAME INVALID", empty, 1, in) %C %and %return w1 = arg1 // 256 ! CONVERT TO ORDINARY NUM cfd: w2 = intpt(w1 * cos(hdcrane / 57.3)) !NEW COORDS w3 = intpt(w1 * sin(hdcrane / 57.3)) ! W2=DX : W3=DY xcrane = xcrane + w2 ycrane = ycrane + w3 arg2 = grablist ! NOW MOVE ANY PICTURES %while arg2 # nil %cycle ! CURRENTLY "GRABBED" w4 = hd(arg2) >> 8 index42(w4)_moved = index42(w4)_moved + imod(w1) curframe = consg(cranemark, consg(w3, consg(w2, consg(w4, %C curframe)))) ! ADD CELL TO FRAMELIST index42(w4)_x = index42(w4)_x + w2 index42(w4)_y = index42(w4)_y + w3 arg2 = tl(arg2) %repeat stack(true) %return ! sysfun(216): !CRANEBACKWARD %if tdev # 8 %then error("DEVICE CANNOT DO ", fn, 1, in) %and %return arg1 = unstack %if arg1 & nm # nm %C %then error("CRANEBACKWARD NEEDS A NUMBER-", arg1, 1, in) %and %C %return %if frameflag = 0 %C %then error("CRANE MOVEMENT OUTSIDE FRAME INVALID", empty, 1, in) %C %and %return w1 = -(arg1 // 256) -> cfd ! sysfun(217): !CRANELEFT/CLEFT %if tdev # 8 %then error("DEVICE CANNOT DO ", fn, 1, in) %and %return arg1 = unstack %if arg1 & nm # nm %C %then error("CRANELEFT NEEDS A NUMBER-", arg1, 1, in) %and %return %if frameflag = 0 %C %then error("CRANE MOVEMENT OUTSIDE FRAME INVALID", empty, 1, in) %C %and %return hdcrane = mod360(arg1 >> 8 + hdcrane) stack(true) %return ! sysfun(218): !CRANERIGHT/CRIGHT %if tdev # 8 %then error("DEVICE CANNOT DO ", fn, 1, in) %and %return arg1 = unstack %if arg1 & nm # nm %C %then error("CRANERIGHT NEEDS A NUMBER", arg1, 1, in) %and %return %if frameflag = 0 %C %then error("CRANE MOVEMENT OUTSIDE FRAME INVALID", empty, 1, in) %C %and %return hdcrane = mod360(hdcrane - arg1 >> 8) stack(true) %return ! sysfun(219): !NEWMOVIE %if tdev # 8 %then error("DEVICE CANNOT DO ", fn, 1, in) %and %return curmovie = nil ! INITIALISES CURRENT MOVIE LIST promp = savepromp %unless frameflag = 0 frameflag = 0 !MAKE SURE NOT IN FRAME prompt(promp) !AND RESTORE PROMPT grablist = nil stack(true) %return ! sysfun(220): !GRAB(VERSION2) %if tdev # 8 %then error("DEVICE CANNOT DO ", fn, 1, in) %and %return arg1 = unstack %if arg1 & wm # wm %then error("I CAN""", arg1, 1, in) %and %return %if frameflag = 0 %C %then error("GRAB NOT VALID OUTSIDE FRAME", empty, 1, in) %and %C %return w1 = arg1 >> 8 %if index42(w1)_ptr42 = 0 %C %then error("GRAB FAILS - PICTURE NOT IN GT42 -", arg1, 1, %C in) %and %C %return %if amongq(arg1, grablist) = 1 %C %then error("I HAVE ALREADY GRABBED ", arg1, 1, in) %and %return grablist = cons(arg1, grablist) xcrane = index42(w1)_x ! MOVE CRANE TO PICTURE ycrane = index42(w1)_y ! COORDINATES stack(true) %return ! sysfun(221): !RELEASE(VERSION2) %if tdev # 8 %then error("DEVICE CANNOT DO ", fn, 1, in) %and %return arg1 = unstack %if arg1 & wm # wm %then error("I CAN""", arg1, 1, in) %and %return %if frameflag = 0 %C %then error("RELEASE NOT VALID OUTSIDE FRAME", empty, 1, in) %and %C %return %if amongq(arg1, grablist) = 0 %C %then error("I HAVE NOT GRABBED ", arg1, 1, in) %and %return grablist = without(arg1, grablist) stack(true) %return ! sysfun(222): !SETCRANE/SETC %if tdev # 8 %then error("DEVICE CANNOT DO ", fn, 1, in) %and %return arg1 = unstack %if frameflag = 0 %C %then error("CRANE MOVEMENT OUTSDIE FRAME INVALID", empty, 1, in) %C %and %return %if arg1 & lm # lm %then error("SETCRANE NEEDS A LIST-", arg1, 1, %C in) %C %and %return arg2 = arg1 ! SAVE ARGUMENT w1 = getnumb(arg1, "SETCRANE") ! CHECK ALL CRANE %if w1 = -100000 %then %return w2 = getnumb(arg1, "SETCRANE") !COORDS BEFORE %return %if w2 = -100000 w3 = getnumb(arg1, "SETCRANE") !ALTERING POSITION %return %if w3 = -100000 xcrane = checkxy(w1) + 512 ycrane = checkxy(w2) + 512 hdcrane = mod360(w3) stack(true) %return ! sysfun(223): !OMIT %if tdev # 8 %then error("DEVICE CANNOT DO ", fn, 1, in) %and %return arg1 = unstack ! GET PICTURE NAME %if arg1 & wm # wm %then error("OMIT NEEDS A WORD-", arg1, 1, in) %C %and %return %if frameflag = 0 %C %then error("OMIT OUTSIDE FRAME INVALID", empty, 1, in) %and %return w1 = arg1 >> 8 %if index42(w1)_ptr42 = 0 %C %then error("OMIT FAILS - PICTURE NOT IN GT42 -", arg1, 1, %C in) %and %C %return grablist = without(arg1, grablist) curframe = consg(index42(w1)_faddr, consg(djump, consg(2, %C consg(index42(w1)_ptr42, consg(setn, curframe))))) stack(true) %return ! %return ! sysfun(224): !GRABLIST %if tdev # 8 %then error("DEVICE CANNOT DO ", fn, 1, in) %and %return stack(grablist) %return %return ! END GRABLIST ! sysfun(228): !CRANEHERE %if tdev # 8 %then error("DEVICE CANNOT DO ", fn, 1, in) %and %return %if frameflag = 0 %C %then error("CRANE COMMAND OUTSIDE FRAME NOT VALID", empty, 1, %C in) %C %and %return w2 = xcrane - 512 w3 = ycrane - 512 w1 = consg(xcrane, consg(ycrane, consg(hdcrane, nil))) stack(w1) %return ! %return ! sysfun(225): !CAPTION %if tdev # 8 %then error("DEVICE CANNOT DO ", fn, 1, in) %and %return capflag = 1 arg1 = unstack printel(arg1) capflag = 0 stack(arg1) %return ! %return ! sysfun(226): !FRAMESPEEDN %if tdev # 8 %then error("DEVICE CANNOT DO ", fn, 1, in) %and %return arg1 = unstack %if arg1 & nm # nm %C %then error("FRAME SPEED NEEDS A NUMBER", arg1, 1, in) %and %return %if frameflag = 1 %C %then error("CANNOT ADJUST FRAMESPEED WITHIN A FRAME", empty, 1, %C in) %and %return %if arg1 < 0 %C %then error("FRAMESPEED NEEDS A +VE NUMBER", arg1, 1, in) %and %C %return frametime = arg1 >> 8 stack(true) %return ! sysfun(227): !KILLFRAME %if tdev # 8 %then error("DEVICE CANNOT DO ", fn, 1, in) %and %return %if frameflag = 0 %C %then error("KILLFRAME FAILS - NO FRAME CURRENT", empty, 1, in) %C %and %return frameflag = 0 prompt(savepromp) prstring("*** FRAME KILLED " . time . " ***") nooline(1) stack(true) %return ! sysfun(229): !WIPE(CLEARSDYNAMICDISPLAYSPACE) ! setcorepointer(corebottom) %cycle w1 = 0, 1, 1022 index42(w1)_ptr42 = 0 %repeat curmovie = nil ! RESET MOVIE LIST stack(true) %return ! END WIPE ! ! sysfun(230): !NOTE(FORMUSICBOX) -> notesw(tdev) ! notesw(1): notesw(2): notesw(3): notesw(4): notesw(5): notesw(7): notesw(8): ! ALL BUT MUSIC error("DEVICE CANNOT DO ", fn, 1, in) %return ! notesw(6): !MUSIC readynum %if jumpflag = 1 %then %return %unless 0 <= arg1 <= 48 %then %start 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 %then %start error("THE SECOND INPUT FOR NOTE MUST LIE BETWEEN 1 AND 256. IT WAS GIVEN ", arg2 << 8 ! nm, 1, in) %return %finish binarg(1, 1) binarg(2, (arg1 << 8) ! (arg2 - 1)) sendbin(0, 2) stack(true) %return ! END NOTE ! ! sysfun(231): !PLAY -> playsw(tdev) ! playsw(1): playsw(2): playsw(3): playsw(4): playsw(5): playsw(7): playsw(8): ! ALL BUT MUSIC error("DEVICE CANNOT DO ", fn, 1, in) %return ! playsw(6): !MUSIC binarg(1, 0) sendbin(0, 1) stack(true) %return ! END PLAY ! ! sysfun(232): !REST sysfun(233): !A0 sysfun(234): !AS0 sysfun(235): !B0 sysfun(236): !C0 sysfun(237): !CS0 sysfun(238): !D0 sysfun(239): !DS0 sysfun(240): !E0 sysfun(241): !F0 sysfun(242): !FS0 sysfun(243): !G0 sysfun(244): !GS0 sysfun(245): !A1 sysfun(246): !AS1 sysfun(247): !B1 sysfun(248): !C1 sysfun(249): !CS1 sysfun(250): !D1 sysfun(251): !DS1 sysfun(252): !E1 sysfun(253): !F1 sysfun(254): !FS1 sysfun(255): !G1 sysfun(256): !GS1 sysfun(257): !A2 sysfun(258): !AS2 sysfun(259): !B2 sysfun(260): !C2 sysfun(261): !CS2 sysfun(262): !D2 sysfun(263): !DS2 sysfun(264): !E2 sysfun(265): !F2 sysfun(266): !FS2 sysfun(267): !G2 sysfun(268): !GS2 sysfun(269): !A3 sysfun(270): !AS3 sysfun(271): !B3 sysfun(272): !C3 sysfun(273): !CS3 sysfun(274): !D3 sysfun(275): !DS3 sysfun(276): !E3 sysfun(277): !F3 sysfun(278): !FS3 sysfun(279): !G3 sysfun(280): !GS3 ! ! stack((sw - 232) << 8 ! nm) %return ! ! sysfun(281): !MOTORA -> motasw(tdev) ! motasw(1): motasw(2): motasw(3): motasw(4): motasw(5): motasw(6): motasw(8): ! ALL BUT MECCANO error("DEVICE CANNOT DO ", fn, 1, in) %return ! motasw(7): !MECCANO -> dropsw(4) ! TURTLE DROP FOR NOW ! ! sysfun(282): !MOTORB -> motbsw(tdev) ! motbsw(1): motbsw(2): motbsw(3): motbsw(4): motbsw(5): motbsw(6): motbsw(8): ! ALL BUT MECCANO error("DEVICE CANNOT DO ", fn, 1, in) %return ! motbsw(7): !MECCANO -> liftsw(4) ! TURTLE LIFT FOR NOW ! ! sysfun(283): !ROTATE arg1 = chdevarg %if arg1 = err %then %return -> rotsw(tdev) ! rotsw(1): rotsw(2): rotsw(3): rotsw(4): rotsw(5): rotsw(6): rotsw(8): ! ALL BUT MECCANO error("DEVICE CANNOT DO ", fn, 1, in) %return ! rotsw(7): !MECCANO -> fdsw(4) ! TURTLE FORWARD FOR NOW ! ! sysfun(284): !PAIR arg1 = chdevarg %if arg1 = err %then %return -> pairsw(tdev) ! pairsw(1): pairsw(2): pairsw(3): pairsw(4): pairsw(5): pairsw(6): pairsw(8): ! ALL BUT MECCANO error("DEVICE CANNOT DO ", fn, 1, in) %return ! pairsw(7): !MECCANO -> leftsw(4) ! TURTLE LEFT FOR NOW ! ! ! ! ! ! ! %end ! END APPLYSYS ! ! ! ! ! %routine eval(%integer in, %integer %name eachval) %integer fn, funspec, type, argno, parmlist, funlist, userenv %integer work1, work2, trace, count, sw, savedev %switch systr(0:2), usrtr(0 : 2), outr(0 : 2) %switch evalsw(0:15) %const %integer markermask = X'FFFFFF0F' %if quitflag = 1 %then %start ! USER INT Q quitflag = 0 jumpout = 0 jumpflag = 1 %if tdev # 0 %then cleset ! CLEAR AND RESET TURTLE DEVICE stack(quit) %return %finish %if holdflag = 1 %and libload = 0 %then %start holdflag = 0 %if in = nil %then stack(val) %and %return %if tdev # 0 %then %start cleset error("USER INTERRUPT - TURTLE DEVICE RESET", empty, 1, in) %return %finish error("USER INTERRUPT", empty, 0, in) %if jumpflag = 1 %then %return %finish ! IF USER INTERRUPT HAS HAPPENED SERVICE IT %if clectflg = 1 %then %start ! GARBAGE COLLECT NEEDED stksys(in) stksys(val) collect(envir) val = unstksys in = unstksys %finish evalcnt = evalcnt + 1 %if evalcnt >= evalimit %then %start error("EVALIMIT EXCEEDED", empty, 1, in) %return %finish %if in & markermask = nil %then %start stack(val) %return %finish lp: %return %if in = nil fn = hd(in) in = tl(in) & markermask top: sw = (fn >> 4) & X'F' ! SWITCH ON MARKER fn = fn & markermask ! REMOVE MARKER -> evalsw(sw) evalsw(1): !QUOTES stack(fn) -> lp evalsw(2): !DOTS top1: work1 = getval(fn, envir) %if work1 = undef %then %start error("NO VALUE HAS BEEN GIVEN TO VARIABLE - ", fn, 0, in) %if jumpflag = 1 %then %return -> top1 %finish %else stack(work1) -> lp evalsw(4): !FUNCTIONNAME ! SPECIAL TREATMENT IS REQUIRED FOR UNARY MINUS AND ANGLE BRACKETS %if fn = unminus %then stack(negate(unstack)) %and -> lp %if fn = langbrks %then %start work2 = nil work1 = hd(in) in = tl(in) %while work1 & markermask # rangbrks %cycle stksys(work2) stksys(in) eval(work1, eachval) in = unstksys work2 = unstksys %if jumpflag = 1 %then %return work2 = cons(unstack, work2) work1 = hd(in) in = tl(in) %repeat stack(reverse(work2)) -> lp %finish ! FINISH ANGLE BRACKETS funspec = fnval(fn >> 8) ! GET FUNCTION SPEC type = funspec & b4 ! GET FUNCTION TYPE %if fnparse(fn >> 8) = 255 %then %start error("FAULTY FIRST LINE OF PROCEDURE-", fn, 0, in) %if jumpflag = 1 %then %return -> evalsw(4) %finish %if fnparse(fn >> 8) = 0 %and type = userpre %then %start ! FN NOT PARSED sindex = fntext(fn >> 8) savedev = device device = srce readinline(promp) ! INPUT FROM SOURCE TEXT plevel = 1 work1 = parseline(0) device = savedev %if work1 = fault %then %start error("ERROR WHILE PARSING", fn, 0, in) %if jumpflag = 1 %then %return -> evalsw(4) %finish funspec = fnval(fn >> 8) type = funspec & b4 %finish %if funspec = 0 %then %start ! UNDEFINED error("UNDEFINED PROCEDURE - ", fn, 0, in) %if jumpflag = 1 %then %return -> evalsw(4) %finish %if type = syspre %or type = userpre %or type = infix %then %start %if type = infix %then argno = 2 %else %start %if type = syspre %then argno = (funspec & b3b) >> 16 %C %else argno = funspec & X'FF' ! GET NUMBER OF ARGS %finish trace = (funspec & traceflg) >> 30 %if type = syspre %or type = infix %then %start %if stkpnt - argno < 0 %then %start error("NOT ENOUGH ARGS FOR ", fn, 1, in) %return %finish -> systr(trace) systr(2): strtrace(fn) %if argno # 0 %then %start ! ARGS EXIST spaces(indent) %cycle work1 = 1, 1, argno ! PRINT VALUES OF ARGS printstring("ARG" . tostring(work1 + 48) . " = ") printel(stk(stkpnt + 1 - work1)) printstring(", ") %repeat nooline(1) %finish -> systr(0) systr(1): strtrace(fn) systr(0): applysys(funspec & b2, fn, in, eachval) %finish %else %start ! FINISH SYSPRE,INFIX : START USERPRE funlist = funspec & m16 ! lm ! FUN NOW HAS USER DEF AS LIST parmlist = tl(tl(hd(funlist))) ! PARAMETRS %if jumpflag = 1 %then stack(parmlist) %and %return userenv = makebind(parmlist, envir, fn) %if userenv = fault %then %start error("NOT ENOUGH ARGS FOR ", fn, 1, in) %return %finish -> usrtr(trace) usrtr(2): strtrace(fn) %if argno # 0 %then %start spaces(indent) work1 = parmlist %cycle count = 1, 1, argno printel(hd(work1)) printstring(" = ") printel(bvalue(userenv - argno + count)) printstring(", ") work1 = tl(work1) %repeat nooline(1) %finish -> usrtr(0) usrtr(1): strtrace(fn) usrtr(0): stksys(in) stksys(val) applyusr(userenv, funlist, tstflg, val, severity) val = unstksys in = unstksys %finish ! FINISH USERPRE -> outr(trace) outr(2): spaces(indent) printstring("RESULT = ") printel(stk(stkpnt)) nooline(1) outr(1): endtrace(fn) outr(0): %if jumpflag = 1 %then %return %finish %else %start ! FINISH SYSPRE/USERPRE/INFIX %if type = interp %then %start ! START INTERP applysys(funspec & b2, fn, in, eachval) %if jumpflag = 1 %then %return %finish %else %start error("ERROR IN FN TYPE FOR EVAL", empty, 1, in) %return %finish %finish ! FINISH INTERP ! %return ! evalsw(0): !POINTER evalsw(8): stksys(in) eval(fn, eachval) in = unstksys %if jumpflag = 1 %then %return -> lp ! ! %end ! END EVAL eval(in, undef) %end ! OF EVALAPPL ! ! %integer %fn parseline(%integer prec) %integer %fn %spec checkhd(%integer hd) %routine %spec topolish(%integer %name arglist, operator) %integer %fn %spec readfndefn %integer %fn %spec parseto %integer %fn %spec parseifc %integer %fn %spec parseif %routine %spec tobottom(%integer op, list) %integer %fn %spec preced(%integer op) %integer %fn %spec parseappmap %integer undefin %integer %fn parse(%integer prec) %integer fn, funspec, type, argno, nextprec %integer polist, arg1list, operator, arg1, item, in %integer work1, work2 %switch interpsw(59:150) in = nil polist = nil arg1list = nil plevel = plevel + 1 lp: fn = headin unusedhd = 0 %if fn = rbrak %then %result = polist ! END OF LINE %if fn = rpar %then %result = polist ! ')' %if fn = comment %then %result = polist ! IGNORE REST OF LINE %if fn = comma %then tailin %and -> lp ! SEPARATOR top: %if fn & nm = nm %then %start ! NUMBER fn = fn ! qu ! QU IS A VALUE MARKER polist = cons(fn, polist) %finish %else %start ! START 0 %if fn = lbrak %then %start ! '[' tailin fn = readlist ! qu ! READLIST polist = cons(fn, polist) %finish %else %start ! START 1 %if fn = quote %then %start ! DATA WORD FOLLOWS quoteon = 1 tailin fn = headin polist = cons(fn ! qu, polist) quoteon = 0 %finish %else %start ! START 2 %if fn = dots %then %start ! DATA NAME FOLLOWS tailin fn = headin %if fn = rbrak %then %start ! ']' parseerr(-1, empty) %result = fault %finish fn = fn ! dts ! DTS IS A NAME MARKER %if fn & wm = wm %then %start polist = cons(fn, polist) %finish %else %start parseerr(-2, fn) %result = fault %finish %finish %else %start ! START 3 %if fn = lpar %then %start ! '(' tailin work1 = parse(4) ! CALL PARSE RECURSIVELY WITH HIGHER PRECEDENCE ! RETURNS ON MATCHING ')' OR END OF LINE %if work1 < 0 %then %result = fault polist = cons((work1 ! lp), polist) tailin %while headin # rpar %and headin # rbrak %finish %else %start ! START 4 %if fn = minus %then %start ! UNARY MINUS. EVAL WITH TOP PREC polist = cons(unminus ! fnm, polist) tailin work1 = parse(100) %if work1 < 0 %then %result = fault polist = cons(work1 ! lp, polist) %finish %else %start ! START 5 %if fn = langbrks %then %start ! << polist = cons(langbrks ! fnm, polist) tailin item = headin %while headin # rbrak %and headin # rangbrks %C %cycle ! UNTIL NEXT ITEM ! IS MATCHING ">>" OR END OF LINE work1 = parse(0) %if work1 < 0 %then %result = fault polist = cons(work1 ! lp, polist) %repeat %if headin = rbrak %then %start parseerr(-3, empty) %result = fault %finish unusedhd = 0 polist = cons(rangbrks ! fnm, polist) polist = reverse(polist) %finish %else %start ! START 6 %if fn = rpar %or fn = rangbrks %then %start ! SPURIOUS ')' OR ">>" parseerr(-4, fn) %result = fault %finish polist = cons(fn ! fnm, polist) ! FNM IS A FN MARKER funspec = fnval(fn >> 8) ! GET FUNCTION SPEC %if funspec = 0 %then %start ! UNDEFINED undefin = 1 ! IF NOT PARSING A FN DEFINITION OR A CONDITION THEN... %if fndefn = 0 %and condflag = 0 %then %start parseerr(-11, fn) %result = fault %finish type = userpre %finish %else type = funspec & b4 %if fn = if %or fn = while %then %start work1 = parseif condflag = condflag - 1 %unless condflag = 0 %result = work1 %finish %if fn = ift %or fn = iff %then %start work1 = parseifc condflag = condflag - 1 %unless condflag = 0 %result = work1 %finish %if type = syspre %or type = userpre %then %start ! PREFIX FUN ! GET NUMBER OF ARGS %if undefin = 1 %then argno = -1 %else %start %if type = syspre %C %then argno = (funspec & b3b) >> 16 %C %else argno = funspec & X'FF' %finish tailin %if argno # 0 %then %start work1 = argno %if work1 < 0 %then %start ! UNKNOWN NUMBER OF ARGS %cycle %exit %if checkhd(headin) = 1 ! CHECK FOR SPECIAL VALUES work2 = parse(10) ! PARSE ARGS %if work2 < 0 %then %result = fault polist = cons(work2 ! lp, polist) %repeat %finish %else %start %while work1 > 0 %cycle ! GATHER ARGS INTO POLIST %if checkhd(headin) = 1 %then %start %exit %if undefin = 1 parseerr(-12, fn) %result = fault %finish work2 = parse(10) %if work2 < 0 %then %result = fault polist = cons(work2 ! lp, polist) work1 = work1 - 1 %repeat %finish %finish %if headin = then %or headin = else %then %C %result = polist %if fn = break %then %start work1 = readlist reptail(polist, work1) %result = polist %finish %if fn = apply %then %start work1 = nil %cycle %exit %if checkhd(headin) = 1 work2 = parse(10) %if work2 < 0 %then %result = fault work1 = cons(work2, work1) %repeat reptail(tl(polist), work1) %result = polist %finish %if fn = repeat %then %start work1 = parse(0) %if work1 < 0 %then %result = fault work2 = tl(polist) reptail(work2, work1) %result = polist %finish %if fn = do %then %start work1 = hd(polist) work2 = hd(tl(polist)) polist = tl(tl(polist)) polist = cons(work2, cons(work1, polist)) %finish unusedhd = 1 polist = cons(polist ! lp, nil) %finish %else %start ! START 7 %if type = interp %then %start -> interpsw(funspec & b2) interpsw(59): !DEFINE %if plevel > 1 %then parseerr(-19, fn) %C %and %result = fault polist = parseto prompt(promp) fndefn = 0 %result = polist ! interpsw(60): !FNDEFINITION--NOTPARSEDUNTILFIRSTCALL %if plevel = 1 %then polist = readfndefn %C %else polist = parseto prompt(promp) fndefn = 0 %result = polist interpsw(148): !MAPLIST interpsw(149): !APPLIST %result = parseappmap %finish %else %start ! START 8 %if type = infix %then %start ! MISPLACED INFIX parseerr(-5, fn) %result = fault %finish %else %start parseerr(-10, empty) %result = fault %finish %finish ! FINISH 8 %finish ! FINISH 7 %finish ! FINISH 6 %finish ! FINISH 5 %finish ! FINISH 4 %finish ! FINISH 3 %finish ! FINISH 2 %finish ! FINISH 1 %finish ! FINISH 0 ! ! ! INFIX LOOP infix: %if headin = rpar %then %start %if fn # lpar %then -> return unusedhd = 0 %finish tailin %unless unusedhd = 1 nextinf: fn = headin %if fn = rbrak %or fn = rpar %or fn & wm # wm %then -> return funspec = fnval((fn >> 8) & X'FFFF') !GET FN DEFN %if funspec = 0 %then -> return !NOT DEFINED AS A FN type = funspec & b4 ! GET TYPE %if type # infix %then -> return ! NOT INFIX nextprec = (funspec & b3b) >> 16 ! GET PREC %if nextprec <= prec %then -> return ! NEXT PREC LOWER THAN CURRENT arg1 = hd(polist) polist = tl(polist) arg1list = cons(arg1, nil) !PUT FIRST ARG ONTO TEMP POLISH LIST operator = fn topolish(arg1list, operator) ! OPERATOR IS THE FN JUST FOUND !ARG1LIST IS UPDATED BEFORE RETURN FROM TOPOLISH %if arg1list = fault %then %result = fault polist = cons(arg1list ! lp, polist) -> nextinf return: unusedhd = 1 %result = polist %end ! END PARSE ! ! %integer %fn checkhd(%integer hd) %integer funspec, type %if hd = rbrak %or hd = rpar %or hd = rangbrks %or hd = and %C %or hd = then %or hd = else %then %result = 1 %if hd & fnm = fnm %then %start funspec = fnval(hd >> 8) type = funspec & b4 %if type = infix %then %result = 1 %finish %result = 0 %end ! ! %routine topolish(%integer %name arg1list, op) %integer polist, op1, work1 polist = nil op1 = op tailin work1 = parse(preced(op)) %if work1 < 0 %then arg1list = fault %and %return polist = work1 ! SPECIAL CASE FOR AND %if op = and %then arg1list = cons(arg1list ! lp, polist) %C %else arg1list = cons(polist ! lp, arg1list) tobottom(op1 ! fnm, arg1list) %return %end ! ! %routine tobottom(%integer item, list) ! INSERT ITEM AT END OF LIST %integer l, newtail la(lpoint) = item la(lpoint + 1) = nil newtail = lpoint << 8 ! lm lpoint = lpoint + 2 l = list %while tl(l) # nil %cycle l = tl(l) %repeat reptail(l, newtail) %end ! ! ! %integer %fn preced(%integer op) ! RETURNS PRECEDENCE OF OP. %integer funspec funspec = fnval(op >> 8) %result = (funspec & b3b) >> 16 %end ! %integer %fn parseifc %integer thenc, fn, ins fn = headin tailin condflag = condflag + 1 thenc = parse(0) %if thenc < 0 %then %result = fault %if fndefn = 1 %then %start thenc = move1(thenc) ins = cons1(fn ! fnm, thenc) %finish %else ins = cons(fn ! fnm, thenc) %result = ins %end ! END OF PARSEIFC ! %const %string (6) strt = "START:" %integer %fn %spec makecondbranch !%ROUTINESPEC PROCESS LINENUMS(%INTEGER LIST) %integer %fn parseif %integer tbranch, fbranch, cond, thenc, elsec, item, fn, work1 tbranch = nil fbranch = nil fn = headin cond = nil tailin %if headin = then %or headin = else %then %start parseerr(-21, empty) %result = fault %finish work1 = parse(0) ! PARSE CONDITION %if work1 < 0 %then %result = fault %if headin = then %then -> thencl %if headin = else %then parseerr(-6, headin) parseerr(-7, headin) %result = fault ! thencl: !THENCLAUSE condflag = condflag + 1 ! DOWN A LEVEL OF CONDITION tailin item = headin %if item = else %then %start parseerr(-22, empty) %result = fault %finish %if item = start %then %start ! START...FINISH prompt(strt) tbranch = makecondbranch prompt(promp) %if tbranch = fault %then %result = fault %finish %else %start thenc = parse(0) %if thenc < 0 %then %result = fault ! IF PARSING A FN DEFINITION MOVE LIST INTO FN DEFN SPACE %if fndefn = 1 %then tbranch = move1(thenc) %else tbranch = thenc %finish %if headin = else %then -> elsecl -> buildcond elsecl: !ELSECLAUSE %if fn = while %then fbranch = nil %else %start tailin item = headin %if item = start %then %start ! START...FINISH prompt(strt) fbranch = makecondbranch prompt(promp) %if fbranch = fault %then %result = fault %finish %else %start elsec = parse(0) %if elsec < 0 %then %result = fault %if fndefn = 1 %then fbranch = move1(elsec) %C %else fbranch = elsec %finish %finish buildcond: %if fndefn = 1 %then %start ! PARSING A FN DEFN work1 = move1(work1) cond = cons1(fn ! fnm, cons1(work1 ! lp, cons1(tbranch, fbranch))) %finish %else %start cond = cons(fn ! fnm, cons(work1 ! lp, cons(tbranch, fbranch))) %finish %result = cond %end ! END OF PARSEIF %integer %fn makecondbranch %integer condlist, work1, linenum, item, linenumlist, ftcondlist, %C txtptr condlist = nil linenumlist = nil %until item = finish %cycle ! PARSE LINES UP TO "FINISH" %if fndefn = 1 %then %start %if device = tty %then %start copyline ! USING "DEFINE" - COPY LINE TO SOURCE txtptr = sourceptr ! PTR TO NEXT SOURCE LINE %finish %else txtptr = sindex %finish readinline(strt) item = headin %if fndefn = 1 %then %start %if item = end %then parseerr(-8, item) %and %result = fault %if item & nm # nm %then %start parseerr(-9, item) -> rep %finish linenum = item tailin item = headin %finish %if item = finish %then work1 = cons(finish, nil) %else %start work1 = parse(0) %if work1 < 0 %then %result = fault %finish %if fndefn = 1 %then %start work1 = move1(work1) ! lp ! MOVE LIST INTO FN DEFN SPACE ! INSERT LINENUMBER AND PTR TO FN TEXT FOR DIAGNOSTICS work1 = cons1(cons1(((txtptr << 16) ! ((linenum >> 8) << 2)), %C work1), nil) %finish %else work1 = cons(cons(sourceptr << 16, work1), nil) ! ADD THIS LINE TO END OF FN LIST %if condlist = nil %then %start condlist = work1 ftcondlist = condlist %finish %else %start reptail(ftcondlist, work1) ftcondlist = tl(ftcondlist) %finish ! IF A FN DEFN THEN ADD THIS LINE TO LINE NUMBER LIST %if fndefn = 1 %C %then linenumlist = cons1(cons1(linenum, ftcondlist), %C linenumlist) rep: %repeat tailin ! INSERT LINE NUMBER INTO START...FINISH LIST %if fndefn = 1 %then %C %result = cons1(start, cons1(linenumlist, condlist)) %else %C %result = cons(start, cons(linenumlist, condlist)) %end %integer %fn readfndefn ! READ TEXT OF A FN INTO SOURCE TEXT FILE %integer starttext, arg1, arg2, index starttext = sourceptr tailin arg1 = headin index = arg1 >> 8 %if arg1 & wm # wm %or arg1 = rbrak %then %start parseerr(-14, arg1) %result = fault %finish arg2 = fnval(index) %if arg2 # 0 %then %start %unless arg2 & userpre = userpre %then %start parseerr(-15, arg1) %result = fault %finish oldfn(index) = fnlen(index) << 16 ! fntext(index) %finish copyline %if sourceptr + 2 * (sourceptr - starttext) + 64 > maxsource %C %then baderror("SOURCE FILE SPACE OVWRFLOW", empty) newfn = fromlist(arg1, newfn) %unless newfn = nil fntext(index) = starttext fnlen(index) = sourceptr - starttext edit(arg1) %unless fnparse(arg1 >> 8) = 255 %then newfn = cons(arg1, newfn) %result = nil %end ! ! ! %integer %fn %spec makearglist(%integer %name len) %integer %fn parseto ! FIRST LINE OF FN ALREADY READ ! PARSE A FN DEFN -- TEXT IS IN SOURCE TEXT FILE IF HEADIN=TO ! OR READ FROM INPUT FILE IF HEADIN=DEFINE ! %integer len, arg1, arg2, arg3, args, fnline, linenum, fn, item, %C redef, fnlist %integer endfnlist, starttext, lentext, index, txtptr, i, rest %const %string (8) fndef = "FN DEFN:" fndefn = 1 redef = 0 fnlist = nil endfnlist = nil linenumlist = nil fn = headin ! TO tailin arg1 = headin ! PROC NAME index = arg1 >> 8 tailin %if fn = def %then %start starttext = sourceptr prompt(fndef) %if arg1 & wm # wm %or arg1 = rbrak %then %start parseerr(-14, arg1) %result = fault %finish arg2 = fnval(index) %if arg2 = 0 %then -> makespec %if arg2 & userpre = userpre %then %start redef = 1 -> makespec %finish %else parseerr(-15, arg1) %result = fault makespec: newfn = fromlist(arg1, newfn) %unless newfn = nil i = 1 i = i + 1 %while inbuff(i) = ' ' !SKIP LEADING SPACES i = i + 1 %while inbuff(i) # ' ' ! SKIP FIRST WORD rest = inbuff(0) - i + 1 %if sourceptr + 2 + rest > maxsource %C %then baderror("SOURCE FILE SPACE OVERFLOW", empty) source(sourceptr) = 'T' source(sourceptr + 1) = 'O' move(rest, addr(inbuff(i)), addr(source(sourceptr + 2))) sourceptr = sourceptr + 2 + rest %finish args = makearglist(len) ! MAKE A LIST OF ARGUMENTS %if args = fault %then %result = fault %if fn = def %then %start %if len > 127 %then %start parseerr(-13, arg1) %result = fault %finish %if redef = 1 %C %then oldfn(index) = fnlen(index) << 8 ! fntext(index) %finish arg3 = cons1(to, cons1(arg1, args)) fnval(index) = userpre + len ! TEMP SPEC TO ALLOW RECURSIVE CALLS ! FN=DEF IMPLIES DEVICE=TTY %if device = tty %then txtptr = sourceptr %else txtptr = sindex ! POINTER TO BEGINNING OF NEXT LINE OF TEXT readinline(fndef) ! READ FIRST LINE item = headin tailin %while item # end %cycle fnline = nil %if item & nm # nm %then %start parseerr(-9, arg1) ! NO NUMBER ON FN LINE -> readline %finish linenum = item ! STORE LINE NUMBER undefin = 0 fnline = parse(0) ! PARSE LINE %if fnline = fault %then parseerr(-20, arg1) %and -> readline fnline = move1(fnline) ! lp ! MOVE INTO FN DEFN SPACE ! INSERT LINENUMBER AND TEXT POINTER IN FN LIST fnline = cons1(cons1(((txtptr << 16) ! ((linenum >> 8) << 2)), %C fnline), nil) ! ADD LINE TO END OF LIST %if fnlist = nil %then %start fnlist = fnline endfnlist = fnlist %finish %else %start reptail(endfnlist, fnline) endfnlist = tl(endfnlist) %finish ! UPDATE LINE NUMBER LIST linenumlist = cons1(cons1(linenum, endfnlist), linenumlist) %if fn = def %then copyline readline: !READNEXTLINE %if device = tty %then txtptr = sourceptr %else txtptr = sindex readinline(fndef) item = headin tailin %repeat %if fn = def %then copyline ! INSERT END INTO SOURCE ! INSERT END INTO FN LIST ! %IF ENDFNLIST=NIL %THEN FNLIST=CONS1(CONS1(END,NIL)!LP,NIL) %if endfnlist = nil %then fnlist = cons1(end, nil) %C %else reptail(endfnlist, cons1(end, nil)) ! INSERT LINE NUMBER LIST INTO FN LIST fnlist = cons1(arg3 ! lp, cons1(linenumlist ! lp, fnlist)) fnval(index) = userpre + fnlist & m16 + len !BUILD SPEC %if fn = def %then %start newfn = cons(arg1, newfn) printel(arg1) %if redef = 1 %then prstring(" REDEFINED") %C %else prstring(" DEFINED") nooline(1) lentext = sourceptr - starttext fntext(index) = starttext fnlen(index) = lentext %finish fnparse(index) = 1 %result = nil %end ! END OF PARSETO ! %integer %fn makearglist(%integer %name len) ! MAKE A LIST OF ARGS. %integer list, word list = nil len = 0 %result = nil %if headin = rbrak %until word = rbrak %cycle -> errlab %unless headin = quote tailin word = headin -> errlab %if word = rbrak %or word & wm # wm list = cons(word, list) len = len + 1 tailin word = headin %repeat tailin %result = reverse1(list) errlab: parseerr(-16, empty) %result = fault %end ! END OF MAKEARGLIST ! ! %integer %fn parseappmap ! SPECIAL SYSTEM FNS APPLIST AND MAPLIST %integer fn, work1, work2 fn = headin tailin work1 = parse(0) %if work1 < 0 %then %result = fault %if work1 = nil %then %start parseerr(-12, fn) %result = fault %finish ! ! PARSE LIST WHICH WILL BE APPLIED TO EACH ARG OF ARG1 ! %if headin = lbrak %then %start tailin work2 = parse(0) tailin %finish %else work2 = parse(0) %if work2 = fault %then %result = fault %if work2 = nil %then %start parseerr(-12, fn) %result = fault %finish %result = cons(work1, cons(fn ! fnm, work2)) %end ! ! ! ! undefin = 0 %result = parse(prec) ! %end ! OF PARSELINE ! ! %routine applyusr(%integer envir, fun, tstflg, val, %integer %name severity) %integer in, nextfun, savestk, linenumlist, curfun, num savestk = stkpnt linenumlist = hd(tl(fun)) nextfun = tl(tl(fun)) %while hd(nextfun) # end %cycle %if nextfun = nil %then %return curfun = hd(nextfun) in = tl(curfun) nextfun = tl(nextfun) evalappl(envir, fun, curfun, in, tstflg, val, severity) %return %if curfun = nil %if goflag = 1 %then %start nextfun = findlinenums(linenumlist) %if nextfun = 0 %then %start num = unstack newline printstring("CANNOT JUMP TO LINE") write(num >> 8, 2) newline jumpflag = 1 goflag = 0 stack(num) %finish %finish %if jumpflag = 1 %then %start ! RETURN FROM USERINT OR ERROR %if sendflag > 1 %then %start sendflag = sendflag - 1 %return %finish %else %start %if sendflag = 1 %then %start sendflag = 0 jumpflag = 0 val = unstack ! VALUE SENT BACK stkpnt = savestk ! RESET STACK stack(val) %return %finish ! SENDFLAG=1 %finish ! SENDFLAG NOT >1 %return ! SENDFLAG=0 %finish ! JUMPFLAG=1 val = unstack %return %if nextfun = nil %repeat stack(val) ! RESULT OF USER FUN-VALUE FROM LAST LINE %end ! END APPLYUSR ! ! ! ! %routine dump(%string (80) errmess) %integer i %integer sysval %byte %integer %name 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 %then %start printstring("W") write(i >> 8, 5) %return %finish %if i & lm = lm %then %start printstring("L") write(i >> 8, 5) %return %finish %if i & nm = nm %then %start printstring("N") spaces(3) %if i < 0 %then write(i >> 8 ! t8, 0) %else write(i >> 8, 0) %return %finish printstring("UNDEF") %end ! END DUMPITEM nooline(1) prstring("DUMPING") nooline(1) selectoutput(1) newlines(5) printstring("********* DUMP STARTS **********" . date . " " . time) newline printstring("ERROR - " . errmess) newline newline printstring("WORD AREA") newline printstring(" INDEX WORD BASE VALUE ") printstring("FNTYPE FNSWITCH FNARGNO/PREC LIST INDX") newline %cycle i = 0, 1, 1022 %if wa(i) = "?" %then -> rep %else %start 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 %then %start write(sysval & X'FFFF', 10) %if type # 4 %then write(argno, 14) %finish %else %start spaces(11) write(sysval & X'FF', 14) spaces(2) printstring("L") write(sysval << 8 >> 16, 4) %finish newline %finish rep: %repeat newline printstring("LIST AREA") newlines(2) printstring("FUNCTION SPACE") newline %if lpoint1 = listop %then %start printstring("NO NEW FNSPACE") newline -> semisp %finish %cycle i = listop, 1, lpoint1 - 1 write(i, 5) spaces(2) dumpitem(la(i)) newline %repeat newline listop = lpoint1 semisp: printstring("CURRENT SEMISPACE") newline %if lpoint = labase %then %start printstring("NO LIST SPACE") newline -> env %finish %cycle i = labase, 1, lpoint - 1 write(i, 5) spaces(2) dumpitem(la(i)) newline %repeat newline env: printstring("LOCAL ENVIRS") newline %if topmark = 1022 %then %start printstring("NO LOCALS") newline %finish %else %start %cycle i = 1023, 1, topmark write(bname(i) >> 8, 5) spaces(2) dumpitem(bvalue(i)) newline %repeat %finish newline printstring("USER STACK") newline %if stkpnt = 0 %then %start printstring("STACK EMPTY") newline %finish %else %start %cycle i = stkpnt, -1, 1 write(i, 5) spaces(2) printel(stk(i)) newline %repeat %finish selectoutput(0) prstring("DUMPED") nooline(1) %end ! END DUMP ! ! %routine initialise %integer i %string (64) in %routine getfuns %string (64) name %integer sysval, tswitch %byte %integer %name type, argno %byte %integer %array %name switch %byte %integer %array %format sf(1 : 2) type == byteinteger(addr(sysval)) switch == array(addr(sysval) + 2, sf) argno == byteinteger(addr(sysval) + 1) lp: readstring(name) %if name = "END" %then %return sysval = 0 read(type) read(tswitch) %if type # 4 %then read(argno) setshortint(switch(1), tswitch) fnval(hash(name) >> 8) = sysval -> lp %end ! END GETFUNS ! ! emasuser = uinfs(1) ! USER NAME AS STRING owner = emasuser masfile = "LOGOFILE" masread = masfile . "," . emasuser . ",R" maswrite = masfile . "," . emasuser . ",WR" %cycle i = 0, 1, 1022 bvalue(i) = 0 fnval(i) = 0 fntext(i) = 0 fnparse(i) = 0 fnlen(i) = 0 oldfn(i) = 0 wa(i) = "?" %repeat space4 = " " quoteon = 0 sourceptr = 1 fndefn = 0 diagflag = 0 condflag = 0 goflag = 0 hashval == intstr(2) work1 == string(addr(intstr(2)) - 1) lbrak == spechar(13) rbrak == spechar(14) tdev = 0 addrbinbuff = addr(binbuff(1)) device = tty userfile = "" cactfile = 0 mdind = 0 mdp = 0 charout = 0 hash1023 = 0 hash1024 = 0 indent = 1 prnum = 0 stkpnt = 0 stktop = 0 systkpnt = 0 jumpflag = 0 jumpout = 0 superjmp = 0 sendflag = 0 quitflag = 0 holdflag = 0 lpoint = la1b labase = la1b lpoint1 = lafnb listop = lafnb semisize = la2b - la1b clectflg = 0 topmark = 1022 basenvir = 1022 numtop = X'007FFFFF' numbot = X'FF800001' evalimit = 1000000 libload = 0 empty == names(2) space1 == names(4) enel == names(6) tab == names(8) true == names(9) false == names(11) quote == names(14) dots == names(16) lpar == names(17) rpar == names(18) comma == names(19) nil == names(20) undef == names(21) then == names(22) else == names(23) end == names(24) delete == names(25) undo == names(26) undos == names(27) to == names(28) do == names(29) err == names(30) logoname == names(31) quit == names(32) break == names(33) if == names(34) close == names(35) while == names(36) thinkaloud == names(37) fact == names(38) implies == names(39) toinfer == names(40) new == names(41) vbl == names(42) not == names(43) database == names(44) imprules == names(45) infrules == names(46) factkeys == names(47) impkeys == names(48) infkeys == names(49) up == names(50) down == names(51) langbrks == names(52) rangbrks == names(53) minus == names(54) quitotop == names(63) start == names(64) finish == names(65) and == names(66) repeat == names(67) apply == names(68) unminus == names(69) comment == names(70) def == names(71) ift == names(72) iff == names(73) selectinput(2) read(cfract) i = 1 lp: readstring(in) %if in # "ENDUP" %then %start names(i) = hash(in) i = i + 1 -> lp %finish %else %start nil = nil >> 8 << 8 ! lm ! CHANGE MARKER ON NIL FROM WM TO LM %cycle i = 0, 1, 1022 assocwa(i) = nil %repeat getfuns %cycle i = 1, 2, 15 setval(names(i), names(i + 1), basenvir) ! INITVALS %repeat initinf setval(thinkaloud, true, basenvir) setval(quitotop, true, basenvir) newfn = nil logotime = time100 selectinput(0) closestream(2) clear("2") getmaster !******* GRAPHICS INITIALISATION curpic = nil defpicture = 0 frameflag = 0 ! NOT WITHIN FRAME curmovie = nil ! NO CURRENT MOVIE curframe = nil grablist = nil %return %finish %end ! END INITIALISE ! ! %routine logo(%integer stktop, envir, severity) %integer val, fun, curfun, tstflg, in val = undef fun = nil in = nil curfun = nil tstflg = 0 prnum = prnum + 1 promp = numtostr(prnum << 8) . ":" prompt(promp) lp: %if tdev = 8 %then set42(chtxt) blevel = 1 readinline(promp) parsecnt = 0 plevel = 0 in = parseline(0) %if in > 0 %then %start evalcnt = 0 evalappl(envir, fun, curfun, in, tstflg, val, severity) %finish %else -> lp %if sendflag > 0 %then %start ! GO BACK TO APPLYUSR %if prnum > 1 %then %start ! NOT AT BASE LEVEL prnum = prnum - 1 promp = numtostr(prnum << 8) . ":" prompt(promp) %return %finish %else %start ! AT BASE LEVEL sendflag = 0 jumpflag = 0 %finish %finish val = unstack %if jumpflag = 1 %then %start ! ERROR RETURN OR USER HAS DONE ! CONTINUE, ABORT OR QUIT stkpnt = stktop ! RESET STACK - DISCARD EXCESS LEFT BY ERROR EXIT %if prnum # 1 %then %start ! NOT AT BASE LEVEL %if jumpout = -1 %then %start ! USER CONTINUE jumpout = 0 jumpflag = 0 prnum = prnum - 1 promp = numtostr(prnum << 8) . ":" prompt(promp) %return %finish %if jumpout > 0 %then %start ! USER ABORT OR QUIT jumpout = jumpout - 1 stack(val) prnum = prnum - 1 promp = numtostr(prnum << 8) . ":" prompt(promp) %return %finish %finish ! FINISH PRNUM#1 jumpflag = 0 ! EITHER PRNUM=1 OR PRNUM#1 AND JUMPOUT=0 jumpout = 0 superjmp = 0 %finish ! FINISH JUMPFLAG=1 -> lp %end ! END LOGO ! %routine ontrap(%integer class, subclass) %integer flag %integer %array info(1 : 32) flag = readid(addr(info(1))) %if subclass = 'Q' %then quitflag = 1 %else holdflag = 1 dresume(0, 0, addr(info(1))) %end ! END ONTRAP ! ! ! ! ! ! ! %on %event 1 %start -> reinit %finish ! %FAULT 17 ->REINIT reinit: %begin ! MAIN PROG STARTS ! reroutecontingency(3, 65, X'20100', ontrap, flag) newsmfile("T#LOGOSTK,436029") define("6,T#LOGOSTK") fstart = smaddr(6, flength) fnval == array(fstart, intform1) oldfn == array(fstart + 4092, intform1) fntext == array(fstart + 8184, intform1) fnlen == array(fstart + 12276, intform1) fnparse == array(fstart + 16368, parseform) systk == array(fstart + 17392, intform2) la == array(fstart + 25392, intform3) bname == array(fstart + 287536, intform4) bvalue == array(fstart + 295448, intform5) assocwa == array(fstart + 307452, intform1) stk == array(fstart + 311544, intform2) wa == array(fstart + 319544, sform1) source == array(fstart + 386029, sourceform) define("2," . masnum . "LOGNAM910") initialise %if restart = 0 %then %start ! NOT A RESTART define("1,T#DUMP") newlines(2) printstring("LOGO - VERSION 9.10 (06/12/81) " . time) newlines(2) %finish %else %start ! RESTART printstring("REINITIALISING AND RELOADING SAVED FUNCTIONS") newline selectinput(3) %finish logo(stktop, basenvir, 0) ! %end %end %of %program