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 ASSSTRING
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<LENGTH(WORD) %THEN GETPAGE(4)
!SAVE=FNTXT(INDEX-1)
!STRING(ADDR(FNTXT(INDEX-1)))=WORD
!NEWIND=INDEX+FNTXT(INDEX-1)
!FNTXT(INDEX-1)=SAVE
!INDEX=NEWIND
!TXTENTS=INDEX-1
end
! END LGPRNT STR
!
routine lgnewline
if device = tty then nooline(1) else lgprntstr(stermin)
end
! END LGNEWLINE
!
routine printword(string (64) word)
if word = "]" or word = ")" then start
lgprntstr(word)
sep = " "
return
finish
if word = "(" or word = "[" or word = """" or word = ":" then start
lgprntstr(sep . word)
sep = ""
return
finish
if word = "+" or word = "-" or word = "*" or word = "/" C
or word = "<" or word = "<=" or word = ">" or word = ">=" C
or word = "=" then start
lgprntstr(word)
sep = ""
return
finish
lgprntstr(sep . word)
sep = " "
return
end
! END PRINTWORD
!
routine printwn(integer i)
string (64) word
if i & nm = nm then start
if i < 0 then word = "-" . numtostr(¬i + 256) C
else word = " " . numtostr(i)
finish else word = wa((i >> 8) & X'FFFF')
printword(word)
end
! END PRINTWN
!
routine printlcon(integer list)
integer i
lp:
if enuf = 1 or (interrupt = "ENUF" and device = tty) 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