begin
!$IF ECSVAX
{%conststring(51) title = %c
{" EUCSD IMP Compiler for M68000. VAX Version 2.3a"
!$IF APM
%conststring(51) title = %c
" EUCSD IMP Compiler for M68000. APM Version 2.3a"
!$FINISH
!
! Hamish Dewar Computer Science Edinburgh University 1982/83/84
!
%constinteger WHICH='.imp'
!<
start2,lim2, {part 2}
lim, {VMLIM}
lbeg,fp,change,flag,
line {line number of current pos},
diff {diff between LINE and ROW},
byte top {top row of sub_window},
win {floating top},
bot {bottom row of sub_window},
min {minimum window size},
row {last row position},
col {last col position},
string (maxname) name)
!
external routine spec EDI(record (edfile)name main,sec,
string (255) message)
{PAM: parameter acquisition module}
constinteger NEWGROUP=1, NODEFAULT=2
external routine spec DEFINE PARAM alias "PAM_DEFSTRING" c
(string (255) name, name variable, integer flags)
external routine spec DEFINE INT PARAM alias "PAM_DEFINT" c
(string (255) name, name variable, integer flags)
external routine spec DEFINE BOOLEAN PARAMS alias "PAM_DEFBOOL" c
(string (255) name, name variable, integer flags)
external routine spec PROCESS PARAMETERS alias "PAM_PROCESS"(string (255) parm)
external routine spec CONNECT EDFILE(record (edfile)name f)
external routine spec DISCONNECT EDFILE(record (edfile)name f)
external string (8)fnspec DATE
external string (5)fnspec TIME
!
owninteger ITEM=0; ![high-frequency]
owninteger LISTOUT=0 {set to 2 if listing to file}
!! Compiler control
constinteger ARRBIT= 16_80000000 {array bound check},
LOOPBIT= 16_40000000 {%for loop check},
CAPBIT= 16_20000000 {capacity check},
OVERBIT= 16_10000000 {overflow check},
ASSBIT= 16_08000000 {integer-unassigned check},
STRASSBIT=16_04000000 {string-unassigned check},
SASSBIT= 16_02000000 {short-unassigned check},
BASSBIT= 16_01000000 {byte-unassigned check},
ASSMASK=assbit!strassbit!sassbit!bassbit,
LINEBIT= 16_00800000 {set line number},
DIAGBIT= 16_00400000,
TRACEBIT= 16_00200000 {plant TRAP 15},
STACKBIT= 16_00100000 {stack over-run check},
CHECKBIT= 16_00080000 {for NOCHECK},
SYSBIT= 16_00040000 {special treatment of SIGNAL},
STRICTBIT=16_00020000,
VOLBIT =16_00010000,
HALFBIT= 16_00008000 {halfword MULT/DIV},
LOWBIT = 16_00004000 {low-level features permitted},
EDITBIT= 16_00002000,
RUNBIT= 16_00001000,
FORCEBIT= 16_00000800,
LOGBIT= 16_00000400 {print log},
WARNBIT= 16_00000200 {print warnings},
NONSBIT= 16_00000100 {nonstandard features permitted},
PERMBIT= 16_00000080 {for PRIM compilation},
OLDBIT= 16_00000040 {for compatibility},
CODELIST= 16_00000020 {list code},
DICTLIST= 16_00000010 {list dict entries},
EXPLIST= 16_00000008 {list EXP entries},
MAPLIST= 16_00000004 {print space map},
TTLIST= 16_00000002 {list to terminal},
LIST= 16_00000001 {do list}
constinteger LISTBITS=codelist+dictlist+explist+maplist+ttlist+list
owninteger CONTROL=warnbit+checkbit+linebit+diagbit+editbit+volbit c
+strassbit+assbit+arrbit+loopbit+capbit+stackbit
integer INITCON,TIME1,TIME2,CCOND
!Events:-
constinteger OFLOW=1, FAIL=11, DONE=12, REDO=13, ABANDON=14
!
!
constinteger MAXINT=16_7FFFFFFF, MININT=\MAXINT
constinteger SIGN16=\16_7FFF, SIGN=\16_7FFFFFFF
!
!!!!!!!!!!!!!!!! Operand Representation !!!!!!!!!!!!!!!!!!!
! Operands (largely, Expressions) are denoted by integers in a
! contiguous range as follows:
!
! <= 0 Literals (including 'addresses' within FINAL)
! [see LITREF and LITVAL for interpretation]
! Dictionary
! __16___16____16____8____8____32____16___16__
! [dummy @ 0] -> |flags|type| link| reg|mode|value|text|hlink|
! D0 [@1] -> R | | | size| | | | | |
! | | |xtype| | | | | |
! D7 -> | | | | | | | | |
! A0 -> E | | | | | | | | |
! | | | | | | | | |
! A7 -> G | | | | | | | | |
! INDA0 -> | | | | | | | | |
! S | | | | | | | | |
! PREA7 -> | | | | | | | | |
! I | | | | | | | | |
! D | | | | | | | | |
! E | | | | | | | | |
! N | | | | | | | | |
! T | | | | | | | | |
! S | | | | | | | | |
! |_____|____|_____|____|____|_____|____|____|
! DICTLIM -> | -- |-- | -- | -- |mode|value| -- | -- |
! C L | | | | | | | | |
! O A | | | | | | | | |
! M B | | | | | | | | |
! P S | | | | | | | | |
! |_____|____|_____|____|____|_____|____|____|
! LABLIM -> |flags|type| act |----|mode|value|arg1|arg2|
! C | | | | | | | | |
! O | | | | | | | | |
! M E | | | | | | | | |
! P X | | | | | | | | |
! L P | | | | | | | | |
! E S | | | | | | | | |
! X |_____|____|_____|____|____|_____|____|____|
! EXPLIM ->
constinteger SMALLMIN=-1024, SMALLMAX=1023,
LITMAX=smallmin-(smallmax+1), LITMIN=litmax-199,
LITMITE=-255, LITQUICK=-16, ONE=-(1<<1)
constinteger D0=1, D1=d0+1, D2=d0+2, D7=d0+7,
A0=d0+8, A1=a0+1, A6=a0+6, A7=a0+7,
INDA0=a0+8, INDA7=inda0+7,
POSTA0=inda0+8, POSTA7=posta0+7,
PREA0=posta0+8, PREA7=prea0+7,
UNDEF=a7
owninteger DICTLIM=1000, FINALBOUND=64 {see Init for adjustment}
integer LABLIM,NP0,EXPLIM {continuing from DICTLIM}
integer CHARBOUND {derived from DICTLIM}
constinteger LABELS=42 {enough for Pascal reserveds},
TRIPLES=200
constinteger AD=16384 {any item + AD >= EXPLIM}
constinteger BREG=D0+4, LINELOC=d0+5
constinteger F1=a0+6, GB=a0+5, MB=a0+4; !level 1, global base, main base
constinteger MAXDREG=d0+3, MAXAREG=a0+3; !max temp regs
constinteger D0B=1, D1B=2, D2B=4, BREGB=16,
A0B=16_100, A1B=16_200, A2B=16_400
constinteger ANYDREG=16_00FF, ANYAREG=16_FF00, ANYREG=16_FFFF
constinteger DEFAULTFREE=(2<<(maxareg-a0)-1)<<8+2<<(maxdreg-d0)-1+bregb
integer MAXCALLDREG, MAXCALLAREG
integer FREE
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!! Big Literals !!!!!!!!!!!!!!!!!!!!!!!
integer LITPOS
integerarray LITSTORE(litmin:litmax)
!
!!!!!!!!! Registers, Identifiers, Labels, Expressions !!!!!!!!!
!
! Operand attributes:
recordformat OBJINFO C
(short FLAGS,TYPE,
(short LINK or short XTYPE or short SIZE or short ACT),
byte REG,MODE,
integer VAL)
recordformat IDENTINFO C
((short FLAGS,TYPE,
(short LINK or short XTYPE or short SIZE or short ACT),
byte REG,MODE,
integer VAL or record (objinfo) DETAILS),
(short TEXT,HLINK or short X,Y))
!
!Machine addressing modes:
constinteger AREGMODE=2_001000, INDIRMODE=2_010000,
DISPMODE=2_101000, INDEXMODE=2_110000, ABSMODE=2_111000,
PCMODE=2_111010, LITMODE=2_111100
!Conversion factors for address register modes (from AREGMODE)
constinteger INDIR=8, POST=16, PRE=24
!Additional source-related modes:
constinteger LABMODE=2_10000000+pcmode,
PROCMODE=2_11000000+pcmode,
GLOBALMODE=dispmode+(gb-a0),
STATIC=2_01000000,
CONSTMODE=static+pcmode,
FRAMEMODE=2_10000000+dispmode
! + 01000000 for dynamic array
constinteger DEFAULTOWNMODE=static+dispmode+(mb-a0)
! MODE,VAL:
! %const simple : LITMODE the actual value
! %const structure : CONSTMODE address in code area
! variable etc : mode byte address/displacement
! undefined label : LABMODE reference chain
! undefined procedure : PROCMODE reference chain
! record format : 0 size of record in bytes
!
! Significance of FLAGS:
constinteger CAT =16_000F, {category: typeid only}
WRITABLE=16_0001,
READABLE=16_0002, {not write only}
VOLATILE=16_0004,
ARRFLAG =16_0008, {bound check needed}
ALT =16_0008, {alternative proc}
WFLAG =16_0010, {has been written to}
RFLAG =16_0020, {has been read from}
OKFLAG =16_0040, {no unassigned check needed, CC OK for fun}
NORET =16_0040, {routine does not return}
MFLAG =16_0080, {has had mem access}
SPEC =16_0100, {unbodied spec or forward label}
TYPEID =16_0200, {type identifier}
PACKED =16_0400,
INDIRECT=16_0800,
PROC =16_3000, {procedure not data}
PROC1 =16_1000,
PROC2 =16_2000,
EXT =16_4000, {external}
NAME =sign16
constinteger HERITABLE=writable+readable+volatile c
+wflag+rflag+okflag+arrflag
!
!CATegories (type identifiers only):
constinteger INTY=0, CHARY=1, BOOLY=2, ENUMY=3,
POINTY=4, REALY=5,
STRINGY=8, ARRY=9, SETY=10,
RECY=12, FILEY=13,
NONORD=12
own record (objinfo) c
DEFINEDLABEL=objinfo(_FLAGS=0,_TYPE=0,_SIZE=0,_REG=0,_MODE=labmode,_VAL=0),
FORWARDLABEL=objinfo(_FLAGS=spec,_TYPE=0,_SIZE=0,_REG=0,_MODE=labmode,_VAL=0),
BEGINBLOCK =objinfo(_FLAGS=0,_TYPE=0,_SIZE=0,_REG=0,_MODE=procmode,_VAL=0),
TYPEIDENT=objinfo(_FLAGS=typeid+recy,_TYPE=0,_SIZE=0,_REG=0,_MODE=0,_VAL=0)
!!!!!!!!!!!!!!!!! File and control initialisation !!!!!!!!!!!!!!!
!
constinteger MAIN=1
record (edfile)array FILE(1:3)
record (edfile)name CUR
integerarray FCONTROL(1:3)
integer CURFILE,LASTFILE; !current source file no (0:3)
integer CURSTART,CURLIM; !current source file bounds
routine SET OPTIONS(string (255) parm)
constinteger CHECKS=assmask+arrbit+loopbit+capbit+overbit
define boolean params( c
"ARR,LOOP,CAP,OVER,ASS,STRASS,SASS,BASS,LINE,DIAG,TRACE,STACK,".C
"CHECK,SYS,STRICT,VOL,HALF,LOW,EDIT,RUN,FORCE,LOG,WARN,NONS,PERM,OLD,".C
"CODE,DICT,EXP,MAP,TT,LIST",control,0)
process parameters(parm)
!NOCHECK => removal of checkbits
control = control&(\checks) if control&checkbit = 0
control = control&(\editbit) if control&listbits # 0
end
routine SET EXTENSION(string (maxname)name f,string (4) ext)
integer strip
integer fn last4(string (*)name s)
integer i,e
i = 0; e = 0
while i < length(s) cycle
i = i+1; e = e<<8+charno(s,i)
repeat
result = e
end
strip = last4(ext)
f = mainfile and strip = which if f = ""
length(f) = length(f)-4 if last4(f)!16_202020 = strip
f = f.ext
end
routine OPEN FILES
string (maxname) LISTFILE=""
objfile = ""
define param("SOURCE",mainfile,nodefault)
define param("OBJ",objfile,newgroup)
define param("LIST",listfile,0)
define int param("IDents",dictlim,newgroup)
define int param("KBytes",finalbound,0)
file(main) = 0
set options(cliparam)
!Main file
file(main)_name = mainfile; file(main)_flag = 32768
time1 = time1-cputime
connect edfile(file(main))
time1 = time1+cputime
stop if file(main)_flag # 0
!Listing file
if listfile # "" or control&(list+ttlist) # 0 start
if control&ttlist = 0 start
set extension(listfile,".lis")
listout = 2
open output(listout,listfile)
finish
control = control&(\(editbit+ttlist))
control = control!list if control&listbits = 0
finish
select output(listout)
if control&listbits # 0 start
control = control!list if control&listbits # maplist
newlines(2)
printstring(title)
newlines(2)
printstring(" "); printstring(file(main)_name)
printstring(" compiled on "); printstring(date)
printstring(" at "); printstring(time)
newlines(2)
finish
initcon = control
end
time1 = 0
open files
dictlim = dictlim+300; !allow for presets
charbound = dictlim*8
finalbound = finalbound<<10+4095; !kilobytes -> bytes + (min) owns
lablim = dictlim+labels
explim = lablim+triples
np0 = lablim+4
file(main)_change = 16_7FFFFFFF
!
!!!!!!!!!!!!!!!! end of file and control initialisation !!!!!!!!
!
record (identinfo)array DICT(0:explim-1)
! indexing DICT:
integer DLIM; !dict limit (up)
integer DLIM0
integer DMIN; !dict upper limit (down)
integer DMIN0
integer DICTSHOWN
integer INCLIM
record (identinfo)name DLINK,DFORMAT,DTEMP,DTEMP2,DTSPREL,DINT
integer SUBBED
integer RANGES
! The identifier dictionary grows as declarations are
! encountered, sequentially from 0 up, so that the
! identifiers within a declaration group and within any block
! are contiguous and may be processed thus (eg at block end).
! However, searching is always through the hash links, with a
! start-point given by the array HASHINDEX. The final link
! value is zero.
! Identifiers are normally added at the start of the hash list
! (hence pushing down any global instance of the same name),
! but identifiers which have been reported as 'not declared'
! are added at the end of the list, using a negative link value.
! This tail section is used to avoid repeated reports for the
! same name (and is ultra-global, ie never removed).
!
! For record formats, the format name is stored in the usual way
! and contains in LINK a pointer to the field-names which are linked
! through what is normally the hash link. Searching for field-names
! proceeds along this chain, as if following hash links.
!
! HLINK is the hash link (index to DICT)
!
! TEXT is the pointer (index to CHAR) to the text of the identifier
! stored as a standard string
! Text of identifiers (indexed by _TEXT):
bytearray CHAR(0:charbound)
integer CHAR0,CHARLIM,CHARMIN; !pointers
integer NEWLEN
! Hash index to DICT:
shortarray HASHINDEX(0:255)
shortname HEAD; !head of ident search list
!
!
!<
!* PRIMGEN marker 1
constinteger NULL=41,
PROCSTAR=42,
INTTYPE=43,
SHORTTYPE=46,
HALFTYPE=49,
BYTETYPE=52,
MITETYPE=55,
BOOLTYPE=58,
CHARTYPE=61,
STRINGSTAR=62,
STRING1=63,
STRINGTYPE=64,
ARRSTAR=65,
NULLSETTYPE=66,
RECSTAR=67,
REALTYPE=69,
SIGNAL=73,
DADDR=74,
DSIZEOF=77,
INDEX=78,
LENREF=79,
SINDEX=82,
IMUL=86,
IDIV=87,
IPOW=88,
FNEG=89,
FADD=90,
FSUB=91,
FMUL=92,
FDIV=93,
FPOW=94,
FLOAT=95,
DREM=98,
UNASS=102,
ADOK=103,
STACKOK=104,
ASIZE=105,
CONCAT=106,
DTOSTRING=107,
AGET=109,
FOROK=110,
CHECK=111,
SCOMP=112,
STRCOPY=113,
STRTOSTK=114,
DNEW=115,
RESOLVES=117,
DEVENTF=128,
DEVENT=134,
DNIL=137,
DPRINTSTR=155,
DWRITE=183
constinteger OPMAX=resolves
routine SET HASHHEAD(string (*)name s)
integer h,i
h = 0
h = h<<1!!charno(s,i) for i = 1,1,length(s)
head == hashindex(h&255)
end
routine PRESET
!* PRIMGEN marker 2
const integer CMAX=775
const byte array CHARINIT(0:CMAX) =
0,
2,'d','0',
2,'d','1',
2,'d','2',
2,'d','3',
2,'d','4',
2,'d','5',
2,'d','6',
2,'d','7',
2,'a','0',
2,'a','1',
2,'a','2',
2,'a','3',
2,'a','4',
2,'a','5',
2,'a','6',
2,'a','7',
7,'i','n','t','e','g','e','r',
6,'M','A','X','I','N','T',
12,'s','h','o','r','t','i','n','t','e','g','e','r',
11,'h','a','l','f','i','n','t','e','g','e','r',
11,'b','y','t','e','i','n','t','e','g','e','r',
11,'m','i','t','e','i','n','t','e','g','e','r',
7,'B','O','O','L','E','A','N',
5,'F','A','L','S','E',
4,'T','R','U','E',
4,'c','h','a','r',
6,'s','t','r','i','n','g',
5,'a','r','r','a','y',
6,'r','e','c','o','r','d',
4,'T','E','X','T',
4,'r','e','a','l',
8,'l','o','n','g','r','e','a','l',
6,'S','I','G','N','A','L',
4,'a','d','d','r',
6,'s','i','z','e','o','f',
5,'I','N','D','E','X',
6,'l','e','n','g','t','h',
6,'c','h','a','r','n','o',
4,'I','M','U','L',
4,'I','D','I','V',
4,'I','P','O','W',
4,'F','N','E','G',
4,'F','A','D','D',
4,'F','S','U','B',
4,'F','M','U','L',
4,'F','D','I','V',
4,'F','P','O','W',
5,'f','l','o','a','t',
3,'r','e','m',
5,'U','N','A','S','S',
4,'A','D','O','K',
7,'S','T','A','C','K','O','K',
5,'A','S','I','Z','E',
6,'C','O','N','C','A','T',
8,'t','o','s','t','r','i','n','g',
4,'A','G','E','T',
5,'F','O','R','O','K',
5,'C','H','E','C','K',
5,'S','C','O','M','P',
7,'S','T','R','C','O','P','Y',
8,'S','T','R','T','O','S','T','K',
3,'n','e','w',
8,'r','e','s','o','l','v','e','s',
9,'s','u','b','s','t','r','i','n','g',
7,'e','v','e','n','t','f','m',
5,'e','v','e','n','t',
3,'s','u','b',
4,'l','i','n','e',
5,'e','x','t','r','a',
7,'m','e','s','s','a','g','e',
5,'e','v','e','n','t',
2,'n','l',
3,'s','n','l',
3,'n','i','l',
7,'d','i','s','p','o','s','e',
5,'r','o','u','n','d',
5,'t','r','u','n','c',
8,'f','r','a','c','t','i','o','n',
3,'i','n','t',
5,'i','n','t','p','t',
6,'f','r','a','c','p','t',
4,'s','q','r','t',
10,'n','e','x','t','s','y','m','b','o','l',
10,'r','e','a','d','s','y','m','b','o','l',
10,'s','k','i','p','s','y','m','b','o','l',
11,'p','r','i','n','t','s','y','m','b','o','l',
11,'p','r','i','n','t','s','t','r','i','n','g',
9,'o','p','e','n','i','n','p','u','t',
10,'o','p','e','n','o','u','t','p','u','t',
11,'s','e','l','e','c','t','i','n','p','u','t',
12,'s','e','l','e','c','t','o','u','t','p','u','t',
8,'s','e','t','i','n','p','u','t',
9,'s','e','t','o','u','t','p','u','t',
10,'r','e','s','e','t','i','n','p','u','t',
11,'r','e','s','e','t','o','u','t','p','u','t',
10,'c','l','o','s','e','i','n','p','u','t',
11,'c','l','o','s','e','o','u','t','p','u','t',
6,'p','r','o','m','p','t',
7,'n','e','w','l','i','n','e',
5,'s','p','a','c','e',
6,'s','p','a','c','e','s',
8,'n','e','w','l','i','n','e','s',
4,'r','e','a','d', 138,'r','e','a','d','s','t','r','i','n','g',
4,'r','e','a','d', 136,'r','e','a','d','r','e','a','l',
4,'r','e','a','d',
5,'w','r','i','t','e',
7,'c','p','u','t','i','m','e',
5,'p','r','i','n','t',
7,'p','r','i','n','t','f','l',
8,'i','n','s','t','r','e','a','m',
9,'o','u','t','s','t','r','e','a','m',
8,'c','l','i','p','a','r','a','m',
0
constinteger PREMAX=196
const short array DICTINIT(41*6:PREMAX*6+5) =
516,-1,0,0,0,0,
527,-1,0,0,0,4,
512,43,4,56,-32768,0,
0,-44,4,60,-32768,0,
0,43,4,60,32767,-1,
512,43,2,56,-32768,0,
0,-44,2,60,-1,-32768,
0,-44,2,60,0,32767,
512,43,2,56,-32768,0,
0,-44,2,60,0,0,
0,-44,2,60,0,-1,
512,43,1,56,-32768,0,
0,-44,1,60,0,0,
0,-44,1,60,0,255,
512,43,1,56,-32768,0,
0,-44,1,60,-1,-128,
0,-44,1,60,0,127,
514,58,1,0,0,0,
0,58,1,60,0,0,
0,58,1,60,0,1,
513,61,255,0,0,0,
520,61,0,0,0,0,
520,-62,-2,0,0,0,
520,-62,-256,0,0,0,
521,0,0,0,0,0,
522,-1,0,0,0,0,
524,0,0,0,0,0,
525,61,4,0,0,0,
517,0,4,0,0,0,
517,0,4,0,0,0,
0,-1,0,0,0,0,
0,-1,0,0,0,0,
4256,42,0,56,0,16122,
4098,75,0,56,0,0,
0,-44,76,0,0,4,
-32701,-1,0,2217,-1,-4,
4098,75,0,56,0,0,
4096,42,0,56,-32767,2861,
4099,80,0,56,0,0,
0,-53,81,2048,0,4,
-32701,-63,0,2217,-1,-4,
4099,83,0,56,0,0,
0,-53,84,2048,0,4,
-32701,-63,85,2217,-1,-4,
67,-44,0,169,-1,-8,
4256,42,0,56,0,16116,
4256,42,0,56,0,16110,
4096,42,0,56,0,16098,
4096,42,0,56,0,16092,
4096,42,0,56,0,16086,
4096,42,0,56,0,16080,
4096,42,0,56,0,16074,
4096,42,0,56,0,16068,
4096,42,0,56,0,16062,
4098,96,0,56,0,16056,
0,-70,97,0,0,4,
67,-44,0,169,-1,-4,
4098,99,0,56,0,0,
0,-44,100,0,0,4,
67,-44,101,169,-1,-4,
67,-44,0,425,-1,-8,
4096,42,0,56,-32722,2578,
4096,42,0,56,-32704,2064,
4096,42,0,56,-32688,2840,
4096,42,0,56,-32664,3097,
4096,42,0,56,-32639,2078,
4162,108,0,56,-32609,6,
0,-64,97,2048,0,4,
4096,42,0,56,-32603,2600,
4096,42,0,56,-32563,2334,
4096,42,0,56,-32533,1806,
4096,42,0,56,-32519,2626,
4096,42,0,56,-32453,2070,
4096,42,0,56,-32431,2088,
4103,116,0,56,0,16008,
0,-68,76,2048,0,4,
22786,118,0,108,0,0,
0,-59,119,0,0,0,
-32701,-63,120,2217,-1,-4,
67,-65,121,2473,-1,-260,
-32701,-63,122,2729,-1,-264,
-32701,-63,0,2985,-1,-268,
4162,124,0,56,-32391,19,
0,-65,125,2048,0,4,
-32701,-63,126,2217,-1,-4,
67,-44,127,169,-1,-8,
67,-44,0,425,-1,-12,
524,0,129,0,-1,-264,
3,52,0,0,0,0,
3,52,0,0,0,1,
3,46,0,0,0,2,
3,43,0,0,0,4,
3,64,0,0,0,8,
67,128,0,45,0,32,
66,43,0,60,0,10,
66,61,0,60,0,10,
67,67,0,56,0,0,
4096,139,0,56,0,16002,
0,-1,76,0,0,4,
4098,141,0,56,0,16050,
0,-44,142,0,0,4,
67,-70,0,169,-1,-4,
4098,141,0,56,0,16044,
4098,145,0,56,0,16038,
0,-70,142,0,0,4,
4098,141,0,56,0,16032,
4098,141,0,56,0,16026,
4098,145,0,56,0,16020,
4098,145,0,56,0,16014,
4098,132,0,56,0,15996,
4098,132,0,56,0,15990,
4096,42,0,56,0,15990,
4256,154,0,56,0,15984,
0,-1,97,0,0,4,
4096,156,0,56,0,15978,
0,-1,157,0,0,4,
67,-65,0,2217,-1,-256,
22784,159,0,108,0,0,
0,-1,160,0,0,0,
67,-44,161,169,-1,-4,
67,-65,0,2217,-1,-260,
22784,159,0,108,0,0,
4096,154,0,56,0,15960,
4096,154,0,56,0,15954,
22784,166,0,108,0,0,
0,-1,97,0,0,0,
22784,166,0,108,0,0,
22784,0,0,108,0,0,
22784,0,0,108,0,0,
22784,0,0,108,0,0,
22784,0,0,108,0,0,
22784,173,0,108,0,0,
0,-1,157,0,0,0,
4096,42,0,56,-32372,4,
4096,42,0,56,-32368,4,
22784,166,0,108,0,0,
22784,166,0,108,0,0,
22790,179,0,108,0,0,
0,-65,0,2048,0,0,
22798,181,0,108,0,0,
0,-70,0,0,0,0,
22798,1,0,108,0,0,
22784,184,0,108,0,0,
0,-1,100,0,0,0,
22790,1,0,108,0,0,
22784,187,0,108,0,0,
0,-1,188,0,0,0,
67,-70,189,169,-1,-4,
67,-44,190,425,-1,-8,
67,-44,0,681,-1,-12,
22784,192,0,108,0,0,
0,-1,193,0,0,0,
67,-70,101,169,-1,-4,
67,43,0,45,0,392,
67,43,0,45,0,396,
67,64,0,45,0,464
integer i,ci,anons
record (identinfo)name dp
routine PUT CHAR
byteinteger(charlim) = charinit(ci)
charlim = charlim+1; ci = ci+1
end
routine TEXTSET(record (identinfo)name dp)
integer len
dp_hlink = 0
if dp_type < 0 start ; !convention for *anon*
dp_type = \dp_type
dp_text = 0
anons = anons-1
dp_hlink = ranges and ranges = dlim if anons = 0 and dlim <= mitetype+2
else
dp_text = ci
if charinit(ci+1)&32 # 0 start ; !not upper-case
if deventf < dlim < devent start
head = dlim; head == dp_hlink
else
set hashhead(string(addr(charinit(ci))))
dp_hlink = head; head = dlim
head == dp_link if dlim = deventf
finish
finish
len = charinit(ci)
put char and len = len-1 until len < 0
len = charinit(ci)-128
put char and len = len-1 while len >= 0
anons = 2
finish
end
hashindex(i) = 0 for i = 0,1,255; !hash table empty
byteinteger(char0) = 0; !for anon ident
charlim = char0+1
charmin = charlim+charbound; !(1 over top)
ranges = 0
ci = 1
anons = 100
dict(0) = 0
dlim = d0
cycle
dp == dict(dlim)
if dlim <= prea7 start
dp = 0
dp_flags = okflag+writable+readable; dp_mode = dlim-d0
dp_type = inttype
textset(dp) if dlim <= a7
else
dp_details = record(addr(dictinit(dlim*6)))
textset(dp)
finish
dlim = dlim+1
exit if control&permbit # 0 and dlim >= signal
repeat until dlim > premax
dictshown = dlim
i = dictlim
cycle
dp == dict(i)
dp = 0
dp_mode = labmode
i = i+1
repeat until i = np0
dict(inttype+9)_size = -1 {byte}
dict(inttype+6)_size = -2 {half}
end ; !preset
!<
! The last part of DICT (from LABLIM to EXPLIM) is used for
! the intermediate representation of the components of source
! statements between the recognition stage and the code generation
! stage.
! The part from LABLIM+4 (NP0) up is used as a temporary pipeline
! for non-expression cells (instructions, conditions, etc)
! and the part down from EXPLIM for the canonical and
! persistent representation of expressions (including name
! expressions).
! In this part of the array the ident components PLIST (etc), TEXT
! and HLINK are replaced by ACT, X and Y representing an operation
! and (up to) two operands.
integer EXPLO,OLDEXPLO
integer NP,STARTNP
!Operator codes:
! Machine operator index values 1-31:
constinteger MOVE=1, ADD=2, SUB=3,
CMP=4, AND=5, OR=6, EOR=7,
NOT=8, NEG=9, LSL=10, LSR=11,
MULS=12, DIVS=13, MULU=14, DIVU=15,
BRA=16, BSR=17,
BCC=20, BCS=21, BNE=22, BEQ=23,
BVC=24, BVS=25,
BGE=28, BLT=29, BGT=30, BLE=31
constinteger COMPARE=cmp, GOTO=bra
! Other built-in operators
constinteger JAMASS=32, OKASS=33, ASSIGN=34, INCASS=35,
FORASS=36, STOP=37, RETURN=38, REPEAT=39,
ELSE=40, JUMPOUT=41, SETTRAP=42, SWGOTO=43,
LABEL=44, RECREF=45, PREL=46, STOREMAP=47,
IABS=48, FABS=49, END=50
! PLUS OPERATORS DEFINED IN DICTIONARY > BOPMAX <= OPMAX
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
integer STARTS, CYCLES
integer CURLAB
integer PENDOUT, PENDCOND, PENDIN, POLARITY, CONDOP
ownshortinteger EXTSPECS=0, EXTERNS=0
!
recordformat CONTENTINFO(short ccx,ccy,line,part,
shortarray content(d0:maxareg))
recordformat BLOCKINF(integer sp, stack, extra, totstack, free, status,
type, localdpos, parlim, localtext, localad, vintage,
localpc, localswpc, pid, access, forward, lab1, looplab,
eventsp, faults, return, shorts, temps,
dynarray, oldcontrol, mode,val,
record (identinfo)name dpid,
record (contentinfo) reg)
!Flag bits
constinteger UNKNOWN =16_0002,
OKCC =16_0004,
ONSTACK =16_0008,
GLOBBED =16_0010,
LABGLOBBED =16_0020, {Pascal}
HADSPEC =16_0040,
HADSWITCH =16_0080,
HADON =16_1000,
HADORDERERR=16_2000,
HADINST =16_4000 {max flag}
constinteger UNSIGNED=4 {flag for operand size}
constinteger MAXLEVEL=7
integer LEVEL; !current block level
integer VINTAGE; !current block number
record (blockinf) C; !info for current block
record (blockinf)array HOLD(0:maxlevel-1); !info for global blocks
record (contentinfo)array LREG(0:labels)
! Code storage for currently open blocks
constinteger PROGBOUND=16383
shortarray PROG(0:progbound)
bytearray PFLAG(0:progbound)
constinteger SHORTJUMP=1, JUMP=2, LONGJUMP=3,
GLOBAL=4, {NEGGLOBAL=5, BIGGLOBAL=6,} INDGLOBAL=7,
ZEROSHORTS=8
integer PC,SWPC
! Final core image
bytearray FINAL(0:finalbound)
! Declaration records (to select relevant context)
integer CAD,
INITBASE,INITLIM,INITHEAD,INITMODE,INITVAL,INITD1,
INITREP,INITDATA
integer OWNMODE,OWNVAL
!
integer FINAL0,ACCOUNTED
integer FIRSTENTRY, FIRSTPOS
!Memo variables for current statement:-
own integer {ITEM,}TYPE=0,VALUE=0; !current operand
record (identinfo)name DITEM
integer SPECCING
integer DUMP
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!! Source file input and listing
owninteger ATOM=0; !current lexical atom
integer MATCHED; !indic that atom has been matched
integer SYM; !current input symbol
integer LINE; !current line number
owninteger CODEFLAG=' '; !or ^
integer LISTFLAG; !' ' or '&' or '+' or '"'
! Pointers to source file:
integer LINESTART
integer FP; !(file pointer) current position
integer ATOMP; !start of current atom
integer EXPP
!
!! Utility routines
predicate IS SHORT(integer v)
false unless -32768 <= v <= 32767
true
end
predicate IS MITE(integer v)
false unless -128 <= v <= 127
true
end
integer fn MITE(integer v)
result = v!(\127) if v&128 # 0
result = v&127
end
!%record(identinfo)%map TYPECELL(%integer t)
! %result == dict(t)
!%end
!
integer fn CATEGORY(integer t)
result = dict(t)_flags&(packed+cat)
end
integer fn LITVAL(integer v)
result = v if v = 0
if v > litmax start ; !not stored literal
result = (-v)>>1 if v&1 = 0
result = \((-v)>>1)
finish
result = litstore(v)
end
!
integer fn ONEBIT(integer y)
integer i
if y < 0 start
y = litval(y)
if y&(y-1) = 0 start
i = -1
i = i+1 and y = y>>1 until y = 0
result = -(i<<1) {litref(i)}
finish
else if np0 <= y < explim and dict(y)_x = one and control&volbit = 0 -
and dict(y)_act = lsl
result = dict(y)_y
finish
result = undef
end
integer fn MULOP(integer xlo,xhi,ylo,yhi)
if (xhi!yhi)&(\65535) = 0 {upper bounds %half} start
result = mulu if xlo!ylo >= 0
result = muls if (xlo+32768)!(ylo+32768) >= 0 -
and (xhi!yhi)&(\32767) = 0
finish
result = imul
end
!!!!!!!!!!!!!! Listing, diagnostic and report routines !!!!!!!!!!!!!!
!
integer FAULTS, OTHERS, FAULTNUM, FAULTP
!
!! Program statistics
integer STATEMENTS; !statement count
integer COMMENTS; !comment count
integer ATOMS; !atom count
integer IDENTATOMS; !identifier count
integer LITATOMS; !numeric atom count
integer ZAPS; !enforced cleardown of lits/exps
integer STEPS; !stepping stones inserted
!%integer MAXIDENTS, MAXCHARS, MAXLITS
integer JUMPS,SHORTS
!
string (255) REP
!
routine PRINT LINE
print string(rep); print symbol(nl)
rep = ""
end
!
routine PUT SYM(integer k)
rep = rep.tostring(k)
end
!
routine PUT STRING(string (255) s)
rep = rep.s
end
!
!
routine PUT NUM(integer val)
routine PD(integer v)
pd(v//10) and v = v-v//10*10 if v <= -10
put sym('0'-v)
end
if val < 0 then put sym('-') and pd(val) c
else pd(-val)
end
!
routine PUT IDENT(integer p,mode)
record (identinfo)name dp
cycle
print line if length(rep) > 50
spaces(6) if rep = ""
dp == dict(p)
put sym(' ') and put sym('"') if mode # 0
if dp_text > 0 then put string(string(char0+dp_text)) c
else if dp_text < 0 then put num(\dp_text) c
else put num(p)
put sym('"') if mode # 0
return if mode <= 0
p = dp_hlink
repeat until p = 0
end
!
{?}routine SPACES(integer n)
{?} while n > 0 cycle
{?} put sym(' '); n = n-1
{?} repeat
{?}end
{?}!
{?}routine PUT SPNUM(integer val)
{?} put sym(' ') if val >= 0
{?} put num(val)
{?}end
{?}
{?}constbytearray hexsym(0:15) =
{?}'0','1','2','3','4','5','6','7','8','9','A','B','C','D','E','F'
{?}
{?}routine PUT HEX(integer val)
{?}integer i
{?} put sym(hexsym(val>>i&15)) for i = 12,-4,0
{?}end
{?}!
{?}routine PUT OPERAND(integer v)
{?}integer i
{?}routine INTERPRET(integer mode)
{?}switch s(0:7)
{?} ->s(mode>>3&7)
{?}s(0): !DREG
{?} put sym('D')
{?}putrno:
{?} put sym(mode&7+'0')
{?} return
{?}s(1): !AREG
{?} if mode >= framemode-dispmode then put sym('F') else put sym('A')
{?} -> putrno
{?}s(4): !PRE
{?} put sym('-')
{?}s(2): !INDIRECT
{?}ind:
{?} put sym('(')
{?} interpret(mode&2_11000111+aregmode)
{?} put sym(')')
{?} return
{?}s(3): !POST
{?} interpret(mode-8); !ind
{?} put sym('+')
{?} return
{?}s(5): !DISP
{?} put num(i)
{?} ->ind
{?}s(6): !INDEX
{?} put num(mite(i))
{?} put sym('(')
{?} interpret(mode+(aregmode-indexmode))
{?} put sym(',')
{?} interpret(i>>12&15)
{?} put sym('.')
{?} if i&16_800 = 0 then put sym('W') else put sym('L')
{?} put sym(')')
{?} return
{?}s(7): !MISC
{?} if mode&63 = pcmode start
{?} put num(i) if mode = pcmode; !suppress if not explicit
{?} put string("(PC)")
{?} return
{?} finish
{?} if mode <= absmode+1 start
{?} put sym('$')
{?} put hex(i>>16) if mode = absmode+1 or not is short(i)
{?} else
{?} put sym(hexsym(mode>>4&3))
{?} put sym(hexsym(mode&15))
{?} put sym('_')
{?} finish
{?} put hex(i)
{?}end
{?}
{?} if v <= 0 start ; !literal
{?} v = litval(v)
{?} put sym('#')
{?} if is mite(v) then put num(v) else start
{?} put sym('$')
{?} put hex(v>>16) if v>>16 # 0
{?} put hex(v&16_FFFF)
{?} finish
{?} else if v <= prea7; !register
{?} interpret(v-d0)
{?} else if v < dictlim; !identifier
{?} put ident(v,0)
{?} else if v < lablim; !internal label
{?} put sym('L')
{?} put num(v-dictlim)
{?} else ; !complex
{?} i = dict(v)_val
{?} interpret(dict(v)_mode)
{?} finish
{?}end ; !put operand
{?}
{?}routine MARK AT(integer col)
{?} put sym(' ') while length(rep) < col; put sym('|')
{?}end
{?}!
{?}routine SHOW DICT(integer from)
{?}integer i
{?}record (identinfo) d
{?}constbytearray flagsym(0:15) =
{?} 'W','R','V','A','w','r','o','m','S','T','K','?','P','p','E','*'
{?}constbytearray catsym(0:15) =
{?} 'I', 'C', 'B', 'E', '@', 'X', '?', '?',
{?} 'S', 'A', 'Z', '?', 'R', 'F', '?', '?'
{?}
{?} return if from >= dlim
!<
{?} print line if rep # ""
{?} byteinteger(charlim) = 0
{?} spaces(6)
{?} put string("___identifier____flags___type__link__par_mode___value____")
{?} print line
{?} cycle
{?} put spnum(from); mark at(6)
{?} d = dict(from)
{?} put sym(' '); put ident(from,0)
{?} if d_text > 0 start
{?} i = char0+d_text; i = i+byteinteger(i)+1
{?} if byteinteger(i)&128 # 0 start
{?} byteinteger(i) = byteinteger(i)-128
{?} put sym(':'); put string(string(i))
{?} byteinteger(i) = byteinteger(i)+128
{?} finish
{?} finish
{?} mark at(22)
{?} if d_flags&typeid # 0 then put sym(catsym(d_flags&cat)) and i = 4 c
{?} else put sym(' ') and i = 0
{?} cycle
{?} put sym(flagsym(i)) if d_flags>>i&1 # 0
{?} i = i+1
{?} repeat until i > 15
{?} mark at(30)
{?} put spnum(d_type); mark at(35)
{?} put spnum(d_link); mark at(42)
{?} put spnum(d_reg); mark at(46)
{?} put spnum(d_mode); mark at(51)
{?} put spnum(d_val); mark at(63)
{?} print line
{?} from = from+1
{?} repeat until from = dlim
{?} spaces(6)
{?} put string("+-------------------------------------------------------+")
{?} print line
!<
{?}end
{?}routine PUT MNEMONIC(integer m)
{?} m = m<<2
{?} cycle
{?} put sym(m>>27+'A'-1)
{?} m = m<<5
{?} repeat until m = 0
{?}end
{?}routine spec PUT OPCODE(integer op)
{?}routine SHOW EXP(integer startp)
{?}integer p,q
{?}record (identinfo)name dp
{?}
constinteger bopmax=51
constintegerarray EXTRA(32:bopmax) =
'j'<<25+('a'&31)<<20+('m'&31)<<15+('a'&31)<<10+('s'&31)<<5+('s'&31),
'o'<<25+('k'&31)<<20+('a'&31)<<15+('s'&31)<<10+('s'&31)<<5,
'a'<<25+('s'&31)<<20+('s'&31)<<15+('i'&31)<<10+('g'&31)<<5+('n'&31),
'i'<<25+('n'&31)<<20+('c'&31)<<15+('a'&31)<<10+('s'&31)<<5+('s'&31),
'f'<<25+('o'&31)<<20+('r'&31)<<15+('a'&31)<<10+('s'&31)<<5+('s'&31),
's'<<25+('t'&31)<<20+('o'&31)<<15+('p'&31)<<10,
'r'<<25+('e'&31)<<20+('t'&31)<<15+('u'&31)<<10+('r'&31)<<5+('n'&31),
'r'<<25+('e'&31)<<20+('p'&31)<<15+('e'&31)<<10+('a'&31)<<5+('t'&31),
'e'<<25+('l'&31)<<20+('s'&31)<<15+('e'&31)<<10,
'e'<<25+('x'&31)<<20+('i'&31)<<15+('t'&31)<<10,
't'<<25+('r'&31)<<20+('a'&31)<<15+('p'&31)<<10,
's'<<25+('w'&31)<<20+('g'&31)<<15+('o'&31)<<10+('t'&31)<<5+('o'&31),
'l'<<25+('a'&31)<<20+('b'&31)<<15+('e'&31)<<10+('l'&31)<<5,
'r'<<25+('e'&31)<<20+('c'&31)<<15+('r'&31)<<10+('e'&31)<<5+('f'&31),
'p'<<25+('r'&31)<<20+('e'&31)<<15+('l'&31)<<10,
's'<<25+('t'&31)<<20+('r'&31)<<15+('m'&31)<<10+('a'&31)<<5+('p'&31),
'i'<<25+('a'&31)<<20+('b'&31)<<15+('s'&31)<<10,
'f'<<25+('a'&31)<<20+('b'&31)<<15+('s'&31)<<10,
'e'<<25+('n'&31)<<20+('d'&31)<<15,
'l'<<25+('o'&31)<<20+('g'&31)<<15+('s'&31)<<10+('u'&31)<<5+('b'&31)
{?}routine PUT OPRAND(integer v)
{?} put sym('#') and v = v-ad if v >= explim
{?} if v < np0 then put operand(v) else put num(v)
{?}end
{?} print line if rep # ""
{?} return unless np > np0
{?} put string(" ______action_______first_______second____")
{?} print line
{?} p = np0
{?} cycle
{?} if p = np start
{?} p = explo
{?} exit if p >= oldexplo
{?} put string(" |---------------------------------------|")
{?} print line
{?} finish
{?} if p = startp then put sym('>') else put sym(' ')
{?} put num(p); mark at(6)
{?} dp == dict(p)
{?} put sym(' ')
{?} q = |dp_act|
{?} if q <= 31 then put opcode(q) c
{?} else if q <= bopmax then put mnemonic(extra(q)) c
{?} else put ident(q,0)
{?} mark at(22)
{?} put sym(' '); put oprand(dp_x); mark at(34)
{?} put sym(' '); put oprand(dp_y); mark at(46)
{?} if p >= explo start
{?} put spnum(dp_type)
{?} put sym('*') if dp_flags < 0
{?} finish
{?} print line
{?} p = p+1
{?} repeat until p >= oldexplo
{?} oldexplo = explo
{?} put string(" +---------------------------------------+")
{?} print line
{?}end
{?}!
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!! Fault reporting !!!!!!!!!!!!!!!!!!!!!!!!!!!
!
routine CROAK(string (255) s)
select output(0)
put string("** "); put string(s)
put string(". Compilation abandoned at line "); put num(line)
print line
signal abandon
end
!<
!! Fault numbers
constinteger INTERNERR=1, PLEXERR=2, CREACHERR=3, REACHERR=4,
NORESULT=5, DREACHERR=6,
FORMERR=7, ATOMERR=8, NAMERR=9, CLASSERR=10,
SIZERR=11, TYPERR=12, BOUNDSERR=13, UNENDING=14,
LOWLEVEL=15, ACCESSERR=16, NOTINLOOP=17, NOTINROUT=18,
NOTINFUN=19, NOTINPRED=20, DUPERR=21,
ORDERERR=22, MATCHERR=23, RANGERR=24, NONLITERAL=25,
MOPERR=26, NOCYCLE=27,
NOSTART=28, NOIF=29, ILLSTARRED=30, NONSTARTER=31,
NONVAR=32, NONREF=33, TOOFEW=34, TOOMANY=35,
NOBEGIN=36, DUBIOUS=37, NOTINBLOCK=38,
NONSTAND=39, NOTIN=40, ASSERR=41,
NOEND=42, NOFINISH=43, NOREPEAT=44
constinteger COUNTERR=45, SLABMISSING=46, IDMISSING=47
constinteger POINT=64, WARN=-128, NOW=128
!
routine REPORT(integer n,id,num)
owninteger lastchange=0
integer mark,start,errline
routine PRINT TEXT(integer stream)
constinteger esc=27
integer k,p
conststring (15)array MESSAGE(1:44) =
"Internal error ", "Reg not free!",
"Out of reach ", " out of reach!",
"RESULT missing", "Out of reach",
"Faulty form", "Unknown atom",
"Unknown name", "Wrong class",
"Wrong size", "Wrong type",
"Inside out", "Endless loop",
"Low level", "Not accessible",
"Not in loop", "Not in routine",
"Not in fn/map", "Not in pred",
"Duplicate",
"Out of order", "Mismatch",
"Out of range", "Not literal",
"Faulty operand", "%CYCLE missing",
"%START missing", "Extra %ELSE",
"Ill-starred", "Non-starter",
"Not variable", "Not reference",
"Too few args", "Too many args",
"%BEGIN missing",
"Dubious usage", "Not in block",
"Nonstandard ", "Not supported",
" void",
"%END missing",
"%FINISH missing", "%REPEAT missing"
!<
put sym(mark)
put sym(' ') if errline < 1000
put sym(' ') if errline < 100
put sym(' ') if errline < 10
put num(errline)
put sym(listflag); put sym(' ')
k = n&63
if k >= counterr start
if k = counterr start
if num < 0 start
put num(-num); put string(" extra")
else
put num(num) if num # 0; put string(" missing")
finish
put string(" value(s) for ")
put ident(id,0)
return
finish
if k # slabmissing start
put ident(id,1)
else
put ident(id,0)
put sym('('); put num(num); put sym(')')
finish
put string(" missing")
mend:
if c_dpid_text # 0 start
put string(" in ")
put ident(c_pid,-1)
finish
return
finish
put ident(id,0) if id > 0
put string(message(k))
put num(num) if num > 0
-> mend if creacherr <= k <= noresult
spaces(22-length(rep))
p = start
p = p+1 while byteinteger(p) = ' '
if p < faultp-50 then p = faultp-47 and put string("...") c
else put sym(' ')
cycle
k = byteintegeR(p); p = p+1
if p = faultp start
if stream # 0 then put sym('|') else start
!**V200**
put sym(esc); put sym('F'); !graphics
put sym('~')
put sym(esc); put sym('G'); !normal
finish
finish
exit if k = nl
put sym(k)
! %if ' ' <= k <= '~' %then put sym(k) %c
! %else put sym('[') %and put num(k) %and put sym(']')
repeat
return
end
!Warning or error
faultnum = 0
if n > 0 start
mark = '*'
c_faults = c_faults+1; faults = faults+1
else
return if control&warnbit = 0
mark = '?'
finish
c_access = -1
!Establish what to print
start = linestart; errline = line
if n&point = 0 start
faultp = 0; !no pointing
else
while start >= faultp cycle ; !before current line
start = start-1
errline = errline-1 if byteintegeR(start) = nl
repeat
start = start-1 while start # curstart and byteintegeR(start-1) # nl
finish
time1 = time1-cputime
if listout # 0 start ; !listing file
print text(listout); print line
finish
select output(0)
if curfile # lastfile start
lastfile = curfile; put string(cur_name); print line
finish
print text(0)
if file(main)_start1 <= fp < lastchange {uncorrected earlier error}-
or n <= reacherr or curfile # main or control&editbit = 0 start
print line
select output(listout)
time1 = time1+cputime
else
start = faultp-1 if faultp > start
cur_fp = start; cur_line = line
cur_change = 16_7FFFFFFE if lastchange # 0
select input(0)
file(main+1) = 0
edi(file(main),file(main+1),rep); !main+1 to keep editor happy
rep = ""
select output(listout)
time1 = time1+cputime
signal abandon if cur_flag < 0 {abandoned}
control = control&(\editbit) if cur_flag = 'I'
lastchange = cur_change and signal redo if cur_change < 16_7FFFFFFE
finish
end ; !report
routine FAULT(integer n)
!Note fault number and position of (earliest) fault
! for subsequent reporting (warnings and weak errors)
if faultnum = 0 or (n > 0 and faultnum < 0) start
faultnum = n; faultp = atomp
report(faultnum&127,0,0) if faultnum >= now
finish
end
routine INTERN(integer n)
report(internerr,0,n)
end
!!!!!!!!!!!!!!!!!!!! CELL CONSTRUCTORS !!!!!!!!!!!!!!!!!!!
!
integer fn LITREF(integer v)
integer i
result = v if v = 0
if v > 0 start
result = -(v<<1) if v <= smallmax
else
result = v<<1+1 if v >= smallmin
finish
litstore(litpos) = v
i = litmin-1
i = i+1 until litstore(i) = v
if i = litpos start
litpos = litpos+1
croak("Too many literals") if litpos >= litmax
finish
result = i
end
!
!!%routine PUT TEMP(%integer f,t,m,v)
!! item = dmin; ditem == dict(item)
!! %while item < dictlim %cycle
!! %return %if ditem_val = v %and ditem_mode = m -
!! %and ditem_type = t %and ditem_flags = f
!! item = item+1; ditem == ditem[1]
!! %repeat
!! dmin = dmin-1
!! croak("Too many identifiers") %if dmin <= dlim
!! item = dmin; ditem == dict(item)
!! ditem = 0
!! ditem_flags = f; ditem_type = t
!! ditem_mode = m; ditem_val = v
!! type = t
!!%end
routine PUTEXP(integer act,x,y,t)
type = t
item = explim
item = x if explo <= x < item
item = y if explo <= y < item
cycle
item = item-1
ditem == dict(item)
if item < explo start
explo = item
ditem_act = act; ditem_x = x; ditem_y = y
ditem_flags = 0; ditem_type = t; ditem_mode = 0
exit
finish
repeat until ditem_act = act and ditem_x = x and ditem_y = y
end
!$IF VAX
{%integer%fn IEEE(%integer v)
{ %result = 0 %if v = 0
{ %result = v<<16+v>>16-16_01000000
{%end
!$FINISH
%routine PUTEXP2(%integer op,first,t)
%if item = 0 %start
!$IF VAX
{ value = ieee(value) %if type = realtype; !vax->ieee
!$FINISH
item = litref(value)
%finish
putexp(op,first,item,t)
%end
%integer%fn NORMITEM
%result = item %if item # 0
!$IF VAX
{ value = ieee(value) %if type = realtype; !vax->ieee
!$FINISH
%result = litref(value)
%end
%routine TOREAL
%if item # 0 %then putexp(float,item,0,realtype) %c
%else real(addr(value)) = value %and type = realtype
%end
%integer%fn TEMP(%integer m,v)
dtemp_mode = m; dtemp_val = v
%result = lablim
%end
%integer%fn TEMPX(%integer r1,r2)
dtemp_mode = r1+(indexmode-a0); dtemp_val = (r2-d0)<<12+16_0800
%result = lablim
%end
%integer%fn TEMPD(%integer a,disp)
dtemp_mode = a+(dispmode-a0); dtemp_val = disp
%result = lablim
%end
%integer%fn TEMPX2(%integer r1,r2)
dtemp2_mode = r1+(indexmode-a0); dtemp2_val = (r2-d0)<<12+16_0800
%result = lablim+1
%end
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!! CODE GENERATION !!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! The array DEF contains packed mnemonics for M68000 machine
! instructions and, for each mnemonic, the basic opcode and
! a type indicator.
! The type indicator contains flag bits for various special cases
! and two 6-bit fields defining the operand types
! [should be const record array]
! The mnemonics and variant distinctions broadly follow the
! manufacturer's Assembly Language conventions
!
! Opcode index values needed globally:-
%constinteger LEA=78, PEA=55, CLR=52, DBRA=81, JSR=56,
LINK=72, UNLK=73, RTS=68,
MOVEM=100, TRAPI=101, DC=102
!Machine-code operand types
%constinteger SHIFT=32
%constinteger DREG=1, AREG=2, IREG=3,
QREG=4, POSTAREG=5, PREAREG=6, DPRE=7,
QUICK=8, TQUICK=9, MQUICK=10, IMM=11,
XIMM=12, DATA=13, REL=14, LONGREL=15,
EA=16, RWEA=17, WEA=18, REVEA=19,
DEA=20, RWDEA=21, WDEA=22, REVDEA=23,
CEA=24, LCEA=25, REVDISP=26, DISP=27
%constinteger DREG9=dreg+shift, QREG9=qreg+shift, IREG9=ireg+shift,
POSTAREG9=postareg+shift,
QUICK9=quick+shift, AREG9=areg+shift,
EXREG9=28+shift
%constinteger SIZED=1<<15, ASIZED=1<<14, QSIZED=1<<13; !1 spare bits
%predicate OKMODE(%integer kind,mode)
%const%byte%array BASIC(0:31) =
2_11111111, 2_00000001{DREG},
2_00000010{AREG}, 2_00000001{IREG},
2_00000001{QREG}, 2_00001000{POSTAREG},
2_00000100{PREAREG}, 2_00000101{DPRE},
0{QUICK}, 0{TQUICK},
0{MQUICK}, 0{IMM},
2_01111100{XIMM}, 0{DATA},
0{REL}, 0{LONGREL},
2_01111111{EA}, 2_01111111{RWEA},
2_01111111{WEA}, 2_01111111{REVEA},
2_01111101{DEA}, 2_01111101{RWDEA},
2_01111101{WDEA}, 2_01111101{REVDEA},
2_01100100{CEA}, 2_01100100{LCEA},
2_00100001{REVDISP}, 2_11111111{DISP},
2_00000011 {EXREG}, 0(*)
const byte array SPECIAL(0:31) =
0, 0{DREG},
0{AREG}, 2_00010000{IREG},
2_00010000{QREG}, 0{POSTAREG},
0{PREAREG}, 0{DPRE},
2_00010000{QUICK}, 2_00010000{TQUICK},
2_00010000{MQUICK}, 2_00010000{IMM},
2_00011111{XIMM}, 2_00000011{DATA},
2_00011100{REL}, 2_00011100{LONGREL},
2_00011111{EA}, 2_00000011{RWEA},
2_00000011{WEA}, 2_00011111{REVEA},
2_00011111{DEA}, 2_00000011{RWDEA},
2_00000011{WDEA}, 2_00011111{REVDEA},
2_00001111{CEA}, 2_00001111{LCEA},
0{REVDISP}, 0{DISP},
0{EXREG}, 0(*)
false unless basic(kind) & 1<<(mode>>3) # 0 -
or (mode-7<<3 >= 0 and special(kind) & 1<<(mode-7<<3) # 0)
true
end
constinteger DEFMAX=130
constintegerarray DEF(0:defmax+defmax) =
0,
{MOVE} 16_0000<<16+ ea<<6+wea+shift +sized,
'm'<<25+('o'&31)<<20+('v'&31)<<15+('e'&31)<<10,
{ADD} 16_D000<<16+ revea<<6+dreg9+sized,
'a'<<25+('d'&31)<<20+('d'&31)<<15,
{SUB} 16_9000<<16+ revea<<6+dreg9+sized,
's'<<25+('u'&31)<<20+('b'&31)<<15,
{CMP} 16_B000<<16+ ea<<6+dreg9 +sized,
'c'<<25+('m'&31)<<20+('p'&31)<<15,
{AND} 16_C000<<16+ revdea<<6+dreg9+sized,
'a'<<25+('n'&31)<<20+('d'&31)<<15,
{OR} 16_8000<<16+ revdea<<6+dreg9+sized,
'o'<<25+('r'&31)<<20,
{EOR} 16_B100<<16+ dreg9<<6+rwdea +sized,
'e'<<25+('o'&31)<<20+('r'&31)<<15,
{NOT} 16_4600<<16+ rwdea +sized,
'n'<<25+('o'&31)<<20+('t'&31)<<15,
{NEG} 16_4400<<16+ rwdea +sized,
'n'<<25+('e'&31)<<20+('g'&31)<<15,
{LSL} 16_E108<<16+ qreg9<<6+dreg +sized,
'l'<<25+('s'&31)<<20+('l'&31)<<15,
{LSR} 16_E008<<16+ qreg9<<6+dreg +sized,
'l'<<25+('s'&31)<<20+('r'&31)<<15,
{MULS} 16_C1C0<<16+ dea<<6+dreg9,
'm'<<25+('u'&31)<<20+('l'&31)<<15+('s'&31)<<10,
{DIVS} 16_81C0<<16+ dea<<6+dreg9,
'd'<<25+('i'&31)<<20+('v'&31)<<15+('s'&31)<<10,
{MULU} 16_C0C0<<16+ dea<<6+dreg9,
'm'<<25+('u'&31)<<20+('l'&31)<<15+('u'&31)<<10,
{DIVU} 16_80C0<<16+ dea<<6+dreg9,
'd'<<25+('i'&31)<<20+('v'&31)<<15+('u'&31)<<10,
{BRA} 16_6000<<16+ rel,
'b'<<25+('r'&31)<<20+('a'&31)<<15,
{BSR} 16_6100<<16+ rel,
'b'<<25+('s'&31)<<20+('r'&31)<<15,
{BHI} 16_6200<<16+ rel,
'b'<<25+('h'&31)<<20+('i'&31)<<15,
{BLS} 16_6300<<16+ rel,
'b'<<25+('l'&31)<<20+('s'&31)<<15,
{BCC} 16_6400<<16+ rel,
'b'<<25+('c'&31)<<20+('c'&31)<<15,
{BCS} 16_6500<<16+ rel,
'b'<<25+('c'&31)<<20+('s'&31)<<15,
{BNE} 16_6600<<16+ rel,
'b'<<25+('n'&31)<<20+('e'&31)<<15,
{BEQ} 16_6700<<16+ rel,
'b'<<25+('e'&31)<<20+('q'&31)<<15,
{BVC} 16_6800<<16+ rel,
'b'<<25+('v'&31)<<20+('c'&31)<<15,
{BVS} 16_6900<<16+ rel,
'b'<<25+('v'&31)<<20+('s'&31)<<15,
{BPL} 16_6A00<<16+ rel,
'b'<<25+('p'&31)<<20+('l'&31)<<15,
{BMI} 16_6B00<<16+ rel,
'b'<<25+('m'&31)<<20+('i'&31)<<15,
{BGE} 16_6C00<<16+ rel,
'b'<<25+('g'&31)<<20+('e'&31)<<15,
{BLT} 16_6D00<<16+ rel,
'b'<<25+('l'&31)<<20+('t'&31)<<15,
{BGT} 16_6E00<<16+ rel,
'b'<<25+('g'&31)<<20+('t'&31)<<15,
{BLE} 16_6F00<<16+ rel,
'b'<<25+('l'&31)<<20+('e'&31)<<15,
{ASL} 16_E100<<16+ qreg9<<6+dreg +sized,
'a'<<25+('s'&31)<<20+('l'&31)<<15,
{ASR} 16_E000<<16+ qreg9<<6+dreg +sized,
'a'<<25+('s'&31)<<20+('r'&31)<<15,
{ROL} 16_E118<<16+ qreg9<<6+dreg +sized,
'r'<<25+('o'&31)<<20+('l'&31)<<15,
{ROR} 16_E018<<16+ qreg9<<6+dreg +sized,
'r'<<25+('o'&31)<<20+('r'&31)<<15,
{MOVEQ} 16_7000<<16+ mquick<<6+dreg9,
'm'<<25+('o'&31)<<20+('v'&31)<<15+('e'&31)<<10+('q'&31)<<5,
{ADDQ} 16_5000<<16+ quick9<<6+rwea +sized,
'a'<<25+('d'&31)<<20+('d'&31)<<15+('q'&31)<<10,
{SUBQ} 16_5100<<16+ quick9<<6+rwea +sized,
's'<<25+('u'&31)<<20+('b'&31)<<15+('q'&31)<<10,
{MOVEA} 16_3040<<16+ ea<<6+areg9 +asized,
'm'<<25+('o'&31)<<20+('v'&31)<<15+('e'&31)<<10+('a'&31)<<5,
{ADDA} 16_D0C0<<16+ ea<<6+areg9 +asized,
'a'<<25+('d'&31)<<20+('d'&31)<<15+('a'&31)<<10,
{SUBA} 16_90C0<<16+ ea<<6+areg9 +asized,
's'<<25+('u'&31)<<20+('b'&31)<<15+('a'&31)<<10,
{CMPA} 16_B0C0<<16+ ea<<6+areg9 +asized,
'c'<<25+('m'&31)<<20+('p'&31)<<15+('a'&31)<<10,
{CMPM} 16_B108<<16+ postareg<<6+postareg9,
'c'<<25+('m'&31)<<20+('p'&31)<<15+('m'&31)<<10,
{ADDI} 16_0600<<16+ imm<<6+rwdea +sized,
'a'<<25+('d'&31)<<20+('d'&31)<<15+('i'&31)<<10,
{SUBI} 16_0400<<16+ imm<<6+rwdea +sized,
's'<<25+('u'&31)<<20+('b'&31)<<15+('i'&31)<<10,
{CMPI} 16_0C00<<16+ imm<<6+rwdea +sized,
'c'<<25+('m'&31)<<20+('p'&31)<<15+('i'&31)<<10,
{ANDI} 16_0200<<16+ imm<<6+rwdea +sized,
'a'<<25+('n'&31)<<20+('d'&31)<<15+('i'&31)<<10,
{ORI} 16_0000<<16+ imm<<6+rwdea +sized,
'o'<<25+('r'&31)<<20+('i'&31)<<15,
{EORI} 16_0A00<<16+ imm<<6+rwdea +sized,
'e'<<25+('o'&31)<<20+('r'&31)<<15+('i'&31)<<10,
{ROXL} 16_E110<<16+ qreg9<<6+dreg +sized,
'r'<<25+('o'&31)<<20+('x'&31)<<15+('l'&31)<<10,
{ROXR} 16_E010<<16+ qreg9<<6+dreg +sized,
'r'<<25+('o'&31)<<20+('x'&31)<<15+('r'&31)<<10,
{CLR} 16_4200<<16+ wdea +sized,
'c'<<25+('l'&31)<<20+('r'&31)<<15,
{NEGX} 16_4000<<16+ rwdea +sized,
'n'<<25+('e'&31)<<20+('g'&31)<<15+('x'&31)<<10,
{NBCD} 16_4800<<16+ rwdea,
'n'<<25+('b'&31)<<20+('c'&31)<<15+('d'&31)<<10,
{PEA} 16_4840<<16+ cea,
'p'<<25+('e'&31)<<20+('a'&31)<<15,
{JSR} 16_4E80<<16+ cea,
'j'<<25+('s'&31)<<20+('r'&31)<<15,
{JMP} 16_4EC0<<16+ cea,
'j'<<25+('m'&31)<<20+('p'&31)<<15,
{TAS} 16_4AC0<<16+ rwdea,
't'<<25+('a'&31)<<20+('s'&31)<<15,
{TST} 16_4A00<<16+ dea +sized,
't'<<25+('s'&31)<<20+('t'&31)<<15,
{ABCD} 16_C100<<16+ dpre<<6+dreg9,
'a'<<25+('b'&31)<<20+('c'&31)<<15+('d'&31)<<10,
{SBCD} 16_8100<<16+ dpre<<6+dreg9,
's'<<25+('b'&31)<<20+('c'&31)<<15+('d'&31)<<10,
{ADDX} 16_D100<<16+ dpre<<6+dreg9 +sized,
'a'<<25+('d'&31)<<20+('d'&31)<<15+('x'&31)<<10,
{SUBX} 16_9100<<16+ dpre<<6+dreg9 +sized,
's'<<25+('u'&31)<<20+('b'&31)<<15+('x'&31)<<10,
{NOP} 16_4E71<<16,
'n'<<25+('o'&31)<<20+('p'&31)<<15,
{RESET} 16_4E70<<16,
'r'<<25+('e'&31)<<20+('s'&31)<<15+('e'&31)<<10+('t'&31)<<5,
{RTE} 16_4E73<<16,
'r'<<25+('t'&31)<<20+('e'&31)<<15,
{RTR} 16_4E77<<16,
'r'<<25+('t'&31)<<20+('r'&31)<<15,
{RTS} 16_4E75<<16,
'r'<<25+('t'&31)<<20+('s'&31)<<15,
{STOP} 16_4E72<<16 +imm,
's'<<25+('t'&31)<<20+('o'&31)<<15+('p'&31)<<10,
{TRAPV} 16_4E76<<16,
't'<<25+('r'&31)<<20+('a'&31)<<15+('p'&31)<<10+('v'&31)<<5,
{TRAP} 16_4E40<<16+ tquick,
't'<<25+('r'&31)<<20+('a'&31)<<15+('p'&31)<<10,
{LINK} 16_4E50<<16+ imm<<6+areg,
'l'<<25+('i'&31)<<20+('n'&31)<<15+('k'&31)<<10,
{UNLK} 16_4E58<<16+ areg,
'u'<<25+('n'&31)<<20+('l'&31)<<15+('k'&31)<<10,
{SWAP} 16_4840<<16+ dreg,
's'<<25+('w'&31)<<20+('a'&31)<<15+('p'&31)<<10,
{EXTW} 16_4880<<16+ dreg,
'e'<<25+('x'&31)<<20+('t'&31)<<15+('w'&31)<<10,
{EXTL} 16_48C0<<16+ dreg,
'e'<<25+('x'&31)<<20+('t'&31)<<15+('l'&31)<<10,
{EXG} 16_C140<<16+ exreg9<<6+dreg,
'e'<<25+('x'&31)<<20+('g'&31)<<15,
{LEA} 16_41C0<<16+ lcea<<6+areg9,
'l'<<25+('e'&31)<<20+('a'&31)<<15,
{CHK} 16_4180<<16+ dea<<6+dreg9,
'c'<<25+('h'&31)<<20+('k'&31)<<15,
{DBXX} 16_50C8<<16+ dreg<<6+longrel,
'd'<<25+('b'&31)<<20+('x'&31)<<15+('x'&31)<<10,
{DBRA} 16_51C8<<16+ dreg<<6+longrel,
'd'<<25+('b'&31)<<20+('r'&31)<<15+('a'&31)<<10,
{DBHI} 16_52C8<<16+ dreg<<6+longrel,
'd'<<25+('b'&31)<<20+('h'&31)<<15+('i'&31)<<10,
{DBLS} 16_53C8<<16+ dreg<<6+longrel,
'd'<<25+('b'&31)<<20+('l'&31)<<15+('s'&31)<<10,
{DBCC} 16_54C8<<16+ dreg<<6+longrel,
'd'<<25+('b'&31)<<20+('c'&31)<<15+('c'&31)<<10,
{DBCS} 16_55C8<<16+ dreg<<6+longrel,
'd'<<25+('b'&31)<<20+('c'&31)<<15+('s'&31)<<10,
{DBNE} 16_56C8<<16+ dreg<<6+longrel,
'd'<<25+('b'&31)<<20+('n'&31)<<15+('e'&31)<<10,
{DBEQ} 16_57C8<<16+ dreg<<6+longrel,
'd'<<25+('b'&31)<<20+('e'&31)<<15+('q'&31)<<10,
{DBVC} 16_58C8<<16+ dreg<<6+longrel,
'd'<<25+('b'&31)<<20+('v'&31)<<15+('c'&31)<<10,
{DBVS} 16_59C8<<16+ dreg<<6+longrel,
'd'<<25+('b'&31)<<20+('v'&31)<<15+('s'&31)<<10,
{DBPL} 16_5AC8<<16+ dreg<<6+longrel,
'd'<<25+('b'&31)<<20+('p'&31)<<15+('l'&31)<<10,
{DBMI} 16_5BC8<<16+ dreg<<6+longrel,
'd'<<25+('b'&31)<<20+('m'&31)<<15+('i'&31)<<10,
{DBGE} 16_5CC8<<16+ dreg<<6+longrel,
'd'<<25+('b'&31)<<20+('g'&31)<<15+('e'&31)<<10,
{DBLT} 16_5DC8<<16+ dreg<<6+longrel,
'd'<<25+('b'&31)<<20+('l'&31)<<15+('t'&31)<<10,
{DBGT} 16_5EC8<<16+ dreg<<6+longrel,
'd'<<25+('b'&31)<<20+('g'&31)<<15+('t'&31)<<10,
{DBLE} 16_5FC8<<16+ dreg<<6+longrel,
'd'<<25+('b'&31)<<20+('l'&31)<<15+('e'&31)<<10,
{BCHG} 16_0140<<16+ ireg9<<6+rwdea +qsized,
'b'<<25+('c'&31)<<20+('h'&31)<<15+('g'&31)<<10,
{BCLR} 16_0180<<16+ ireg9<<6+wdea +qsized,
'b'<<25+('c'&31)<<20+('l'&31)<<15+('r'&31)<<10,
{BSET} 16_01C0<<16+ ireg9<<6+wdea +qsized,
'b'<<25+('s'&31)<<20+('e'&31)<<15+('t'&31)<<10,
{BTST} 16_0100<<16+ ireg9<<6+dea +qsized,
'b'<<25+('t'&31)<<20+('s'&31)<<15+('t'&31)<<10,
{MOVEM} 16_4880<<16+ ximm<<6+ea+asized,
'm'<<25+('o'&31)<<20+('v'&31)<<15+('e'&31)<<10+('m'&31)<<5,
{TRAPI} 16_4E40<<16+ imm<<6+tquick,
't'<<25+('r'&31)<<20+('a'&31)<<15+('p'&31)<<10+('i'&31)<<5,
{DC} data,
'd'<<25+('c'&31)<<20,
{ST} 16_50C0<<16+ wea,
's'<<25+('t'&31)<<20,
{SF} 16_51C0<<16+ wea,
's'<<25+('f'&31)<<20,
{SHI} 16_52C0<<16+ wea,
's'<<25+('h'&31)<<20+('i'&31)<<15,
{SLS} 16_53C0<<16+ wea,
's'<<25+('l'&31)<<20+('s'&31)<<15,
{SCC} 16_54C0<<16+ wea,
's'<<25+('c'&31)<<20+('c'&31)<<15,
{SCS} 16_55C0<<16+ wea,
's'<<25+('c'&31)<<20+('s'&31)<<15,
{SNE} 16_56C0<<16+ wea,
's'<<25+('n'&31)<<20+('e'&31)<<15,
{SEQ} 16_57C0<<16+ wea,
's'<<25+('e'&31)<<20+('q'&31)<<15,
{SVC} 16_58C0<<16+ wea,
's'<<25+('v'&31)<<20+('c'&31)<<15,
{SVS} 16_59C0<<16+ wea,
's'<<25+('v'&31)<<20+('s'&31)<<15,
{SPL} 16_5AC0<<16+ wea,
's'<<25+('p'&31)<<20+('l'&31)<<15,
{SMI} 16_5BC0<<16+ wea,
's'<<25+('m'&31)<<20+('i'&31)<<15,
{SGE} 16_5CC0<<16+ wea,
's'<<25+('g'&31)<<20+('e'&31)<<15,
{SLT} 16_5DC0<<16+ wea,
's'<<25+('l'&31)<<20+('t'&31)<<15,
{SGT} 16_5EC0<<16+ wea,
's'<<25+('g'&31)<<20+('t'&31)<<15,
{SLE} 16_5FC0<<16+ wea,
's'<<25+('l'&31)<<20+('e'&31)<<15,
{MTCCR} 16_44C0<<16+ dea,
'm'<<25+('t'&31)<<20+('c'&31)<<15+('c'&31)<<10+('r'&31)<<5,
{MTSR} 16_46C0<<16+ dea,
'm'<<25+('t'&31)<<20+('s'&31)<<15+('r'&31)<<10,
{MFSR} 16_40C0<<16+ wdea,
'm'<<25+('f'&31)<<20+('s'&31)<<15+('r'&31)<<10,
{MTUSP} 16_4E60<<16+ areg,
'm'<<25+('t'&31)<<20+('u'&31)<<15+('s'&31)<<10+('p'&31)<<5,
{MFUSP} 16_4E68<<16+ areg,
'm'<<25+('f'&31)<<20+('u'&31)<<15+('s'&31)<<10+('p'&31)<<5,
{ATCCR} 16_023C<<16+ imm,
'a'<<25+('t'&31)<<20+('c'&31)<<15+('c'&31)<<10+('r'&31)<<5,
{ATSR} 16_027C<<16+ imm,
'a'<<25+('t'&31)<<20+('s'&31)<<15+('r'&31)<<10,
{ETCCR} 16_0A3C<<16+ imm,
'e'<<25+('t'&31)<<20+('c'&31)<<15+('c'&31)<<10+('r'&31)<<5,
{ETSR} 16_0A7C<<16+ imm,
'e'<<25+('t'&31)<<20+('s'&31)<<15+('r'&31)<<10,
{OTCCR} 16_003C<<16+ imm,
'o'<<25+('t'&31)<<20+('c'&31)<<15+('c'&31)<<10+('r'&31)<<5,
{OTSR} 16_007C<<16+ imm,
'o'<<25+('t'&31)<<20+('s'&31)<<15+('r'&31)<<10,
{MOVEP} 16_0120<<16+ revdisp<<6+dreg9+asized,
'm'<<25+('o'&31)<<20+('v'&31)<<15+('e'&31)<<10+('p'&31)<<5
{?}routine PUT OPCODE(integer op)
{?} put mnemonic(def(op+op))
{?}end
routine STORE(integer v,f)
pflag(pc) = f
!$IF VAX
{ v = v&16_FFFF; v = v!sign16 %if v&sign16 # 0
!$FINISH
prog(pc) <- v; pc = pc+1
%end
%routine MAKE INIT ROOM(%integer size)
%integer newbase
%if initlim+size >= finalbound %start
size = (size+127)&(\127)
initbase = initbase-size
croak("Program too big") %if initbase <= cad
initlim = initlim-size; inithead = inithead-size %if inithead > 0
newbase = initbase
%cycle
final(newbase) = final(newbase+size)
newbase = newbase+1
%repeat %until newbase >= initlim
%finish
%end
%routine FILL CODE(%integer n)
%integer i
i = cad; cad = cad+n
%while i < cad %cycle
final(i) = 16_80; i = i+1
%repeat
%end
%routine SET CODE WORD(%integer v)
!$IF VAX (works irrespective of host byte sex)
{ final(cad) <- v>>8; final(cad+1) <- v
!$IF APM (for efficiency)
shortinteger(final0+cad) <- v
!$FINISH
cad = cad+2
%end
%integer%fn CODE WORD(%integer cad)
!$IF VAX (works irrespective of host byte sex)
{ %result = final(cad)<<8+final(cad+1)
!$IF APM (for efficiency)
%result = shortinteger(final0+cad)
!$FINISH
%end
%routine SET CODE LONGWORD(%integer v)
set code word(v>>16); set code word(v)
%end
%routine PUT OWN WORD(%integer v)
make init room(2)
!$IF VAX
{ final(initlim) <- v>>8; final(initlim+1) <- v
!$IF APM
shortinteger(final0+initlim) <- v
!$FINISH
initlim = initlim+2
%end
%routine INIT ADEVAL(%integer mode,val)
! Generate INIT code to evaluate new initialisation address to A1
%if %not is short(val) %start
fault(dreacherr) %if mode&63 # absmode
put own word(16_43F9); !LEA xxxxxxxx,A1
put own word(val>>16)
put own word(val)
%else %if mode&2_111000 = dispmode %and val = 0
put own word(16_2248+mode&7); !MOVE A?,A1
%else
put own word(16_43C0+mode&63); !LEA ?,A1
put own word(val)
%finish
initmode = mode; initval = val
%end
%routine END PATTERN
%integer i
%return %if inithead <= 0
%if initlim&1 # 0 %start
final(initlim) <- 16_80
initlim = initlim+1; initval = initval+1
%finish
! Insert length of data (halfwords-1)
shortinteger(final0+inithead) <- (initlim-inithead)>>1-2
inithead = 0
%end
%routine START PATTERN
%integer i
%return %if inithead > 0 {pattern started}
i = initbase-initlim-14
if i >= -128 then put own word(16_6100+256+i) -
else put own word(16_6100) and put own word(i)
put own word(0); inithead = initlim-2; !length word
end
routine END RUN
integer i
return if initrep <= 0
if initlim&1 # 0 start {odd byte in pattern}
final(initlim) <- initdata
initlim = initlim+1; initrep = initrep-1
return if initrep = 0
finish
if initrep >= 16 start
end pattern
i = initrep&(\1)-1
if i <= 127 start
put own word(16_7000+i); !MOVEQ #?,D0
else
put own word(16_303C); put own word(i); !MOVE.W #?,D0
finish
if initdata # initd1 start
initd1 = initdata
put own word(16_7200+initd1&255); ! MOVEQ #?,D1
finish
put own word(16_12C1); ! MOVE.B D1,(A1)+
put own word(16_51C8); ! DBRA D0,#-4
put own word(-4)
initrep = initrep&1
finish
if initrep > 0 start
! %if inithead > 0 %start
start pattern
make init room(initrep)
cycle
final(initlim) = initdata
initlim = initlim+1; initrep = initrep-1
repeat until initrep = 0
! %else
finish
initrep = 0
end
routine PATTERN(integer mode,val,size)
end run
if mode # initmode or val # initval start
end pattern
init adeval(mode,val)
finish
start pattern
initval = initval+size
end
routine RUN(integer mode,val,n,v)
end run if v # initdata
if mode # initmode or val # initval start
end run; end pattern
init adeval(mode,val)
finish
initdata = v; initrep = initrep+n
initval = initval+n
end
routine EXTEND STACK(integer delta)
c_sp = c_sp-delta
if c_sp < c_stack start
c_stack = c_sp
c_totstack = c_stack if c_stack < c_totstack
finish
end
routine PLANT(integer op,y,x)
!Basic code planting procedure
! OP is an index to the array defining op-codes
! (it can be flagged to force SIZE)
! For unary operations the operand is given by X (Y zero)
! For binary operations the operands are Y (source) and X (dest)
integer OPCODE,PC1,I,F,EXTWORD,INFO,KIND,MODE,MODEX,SIZE,ADJUSTMENT
record (identinfo)name DX,DY
switch S(0:31)
constbytearray SIZESYM(0:3) = 'L','B','W','?'
integer fn NONLOCAL(integer l)
integer r
result = mb if l = 0
hold(l)_status = hold(l)_status!globbed if l # level
result = f1 if l = 1
r = maxareg
cycle
result = r if c_reg_content(r) = d7+l {unique}
r = r-1
repeat until r < a0
![not good enough: 1. may need two
! 2. FREE updated elsewhere without regard to this]
r = maxareg
while a0b<<(r-a0)&free = 0 cycle
fault(plexerr) and exit if r = a0
r = r-1
repeat
c_reg_content(r) = d7+l
dtsprel_mode = globalmode; dtsprel_val = l<<2
plant(move,lablim+2,r)
result = r
end
constinteger MOVEQ=36, ADDQ=37, MOVEA=39,
ADDA=40, ADDI=44
if x > 0 start
intern(1) and return if x >= explim
dx == dict(x)
modex = dx_mode
if modex >= framemode and modex # c_mode c
and modex&2_111000 # 2_111000 start
modex = nonlocal(modex&7)-a0+(modex&(7<<3))
finish
finish else modex = litmode and dx == dint
if y > 0 start
intern(1) and return if y >= explim
dy == dict(y)
mode = dy_mode
if mode >= framemode and mode # c_mode c
and mode&2_111000 # 2_111000 start
mode = nonlocal(mode&7)-a0+(mode&(7<<3))
finish
finish else mode = litmode and dy == dint
size = op>>8; op = op&255
if op = move start
if modex&2_111000 = 0 start {Dx}
op = moveq if y <= 0 and y >= litmite and size&3 = 0
else if modex&2_110000 = 0 {Ax}
op = movea
finish
else if op <= cmp
if op < cmp and y < 0 and y >= litquick and y&1 = 0 c
then op=op+(addq-add) {ADDQ,SUBQ} c
else if modex&2_111000 = aregmode c
then op=op+(adda-add) {ADDA,SUBA,CMPA} c
else if y <= 0 and modex&2_111000 # 0 c
then op=op+(addi-add) {ADDI,SUBI,CMPI}
else if op <= eor
op = op+(addi-add) if y <= 0 -
and (op = eor or modex&2_111000 # 0) {ANDI,ORI,EORI}
finish
info = def(op+op-1)
opcode = info>>16
if info&sized # 0 start {B,W,L sized}
size = 4 if size = 0
if op = move start
if size = 4 then opcode = opcode+16_2000 c
else if size = 2 then opcode = opcode+16_3000 c
else opcode = opcode+16_1000
else
if size = 4 then opcode = opcode+16_80 c
else if size = 2 then opcode = opcode+16_40
finish
else if info&asized # 0 {W,L sized}
fault(sizerr) if size = 1
if size = 0 start
size = 4 unless y <= 0 and is short(litval(y)) and op < movem
finish
if size = 4 start
if op >= movem then opcode = opcode+16_0040 {MOVEM,MOVEP} -
else if op # movea then opcode = opcode+16_0100 -
else opcode = opcode!!16_1000
finish
finish
{?} if control&codelist # 0 and control&list # 0 start
{?} print line if length(rep) >= 4
{?} put sym(codeflag); spaces(4-length(rep))
{?} put opcode(op)
{?} if size # 0 start
{?} put sym('.')
{?} put sym(sizesym(size&3))
{?} finish
{?} spaces(12-length(rep))
{?} if info&(63<<6) # 0 start
{?} put operand(y)
{?} put sym(',')
{?} finish
{?} put operand(x) if info&63 # 0
{?} spaces(33-length(rep)); put sym(':')
{?} finish
pc1 = pc; pflag(pc1) = c_shorts; !op-code word
pc = pc+1
croak("Code space exhausted") if pc+8 >= swpc
adjustment = 0
-> next if info&31<<6 = 0
kind = info>>6
again:
-> err if not okmode(kind&31,mode&63)
-> s(kind&31)
next:
kind = info
if kind # 0 start
dy == dx; y = x; mode = modex
info = 0
->again
finish
!
s(0):
!$IF VAX
{ opcode = opcode!sign16 %if opcode&sign16 # 0
!$FINISH
prog(pc1) <- opcode
{?} if control&codelist # 0 and control&list # 0 start
{?} cycle
{?} put sym(' ')
{?} put hex(prog(pc1))
{?} pc1 = pc1+1
{?} repeat until pc1 >= pc
{?} print line
{?} finish
return
!Set flag value for PC-relative reference
! distinguishing GLOBAL (const access), INDIRECT GLOBAL (procedure),
! and LOCAL (label) -- the last further distinguished according to
! whether the instruction permits shortening
routine PCREL(integer shorten)
if dy_mode = labmode start
f = jump; f = longjump if shorten = 0
if extword > 0 start ; !label defined
if shorten # 0 and (extword-pflag(extword)-pc+c_shorts)<<1 >= -128 start
if c_shorts = 255 start
zaps = zaps+100
else
shorts = shorts+1; c_shorts = c_shorts+1
f = shortjump
finish
finish
else
extword = -extword
dy_val = -pc
finish
else if dy_mode = procmode; !procedure
f = indglobal; extword = y; !rather than DY_VAL
else if dy_mode = constmode; !constant data ref
f = global
f = f+1 if extword < 0
f = f+2 if extword > 65535
finish
end
s(lcea): !LEA
if mode&63 = x-(a0-indexmode) and dy_val&255 = 0 start
! LEA 0(Ax,Dy),Ax => ADDA Dy,Ax
opcode = 16_D1C0+dy_val>>12&15
-> next
finish
s(cea): !Control addressing modes
-> ea0 unless (op = lea or op = pea) and mode&63 # pcmode
!taking address: might read or write
dy_flags = dy_flags!(mflag+rflag+wflag)
-> ea1
s(wea): s(wdea):
dy_flags = dy_flags!(mflag!wflag)
-> ea1
s(rwea): s(rwdea):
![for our purposes, read&write counts as neither]
dy_flags = dy_flags!mflag
-> ea1
s(revdisp): !MOVEP
if modex&2_111000 # 0 start
kind = shift; info = disp
opcode = opcode!!16_0080
-> sreg
finish
-> ea0
s(revea): s(revdea):
!reversible cases (EA,DREG or DREG,EA)
if modex&2_111000 # 0 start ; !dest not D
kind = shift; info = rwea
opcode = opcode!!16_0100
->sreg
finish
s(ea):s(dea):
ea0:
if y <= 0 start
opcode = opcode+litmode; !immediate
->simm
finish
if dy_flags&(ext+spec+rflag+wflag) = ext+spec c
and dy_flags&proc # 0 start
! Create transfer vector for external procedure
ownval = ownval+1 if ownval&1 # 0
dy_val = ownval
ownval = ownval+6 {6 bytes for %system}
ownval = ownval+6 if dy_flags&proc2 # 0 {12 for %external}
finish
dy_flags = dy_flags!(mflag+rflag)
s(disp):
ea1:
extword = dy_val+adjustment
if mode = c_mode start ; !local
mode = dispmode+7; extword = extword-c_sp; !convert to use SP
if extword < 0 start
intern(4) if extword < -4
mode = aregmode+pre+7
extend stack(-extword)
extword = 0
finish
finish
mode = mode&63; !strip extra flags
if mode >= dispmode start ; !+extra
f = 0
if mode = pcmode start
pcrel(0)
finish
if mode <= dispmode+7 start
if extword = 0 start
! Premode (just created) or Dispmode (=>Indmode)
mode = mode+(indirmode-dispmode) if mode >= dispmode
else
fault(dreacherr) unless -32768 <= extword <= 32767
store(extword,f)
finish
else
mode = absmode+1 if mode = absmode and not is short(extword)
store(extword>>16,0) if mode = absmode+1
store(extword,f)
finish
finish
mode = ((mode&7)<<3 + mode>>3)<<6 if kind&shift # 0
opcode = opcode!!mode
-> next
s(exreg9&31): !EXG (D,D / A,A / D,A)
if mode&2_111000 = 0 start ; !D
if modex&2_111000 # 0 start ; !not D
opcode = opcode!!16_C8; info = areg
finish
-> sreg
finish
opcode = opcode+8; info = areg
-> sareg
s(dpre):
-> sreg if mode&2_111000 = 0; !D
opcode = opcode+8; info = preareg+shift
s(preareg):
mode = mode+(post-pre)
s(postareg):
mode = mode-post
s(areg): sareg:
mode = mode-8
s(dreg): sreg:
-> err unless mode&(\7) = 0
mode = mode<<9 if kind&shift # 0
opcode = opcode+mode
->next
s(qreg): !Shift formats -- quick,Dx / Dy,Dx / 1,<ea> (W)
opcode = opcode+16_20 and ->sreg if y > 0
if y = one and size = 2 and modex&2_111000 # 0 start
opcode = opcode!!16_290
->next
finish
s(quick):
-> err if y >= 0
y = litval(y)
->err unless y <= 8
opcode = opcode+(y&7)<<9; !(always aligned to bit9)
->next
s(tquick): !(TRAP)
->err unless y >= -30 and y&1 = 0; ! 0 <= litval(y) <= 15
s(mquick):
->err unless y >= litmite
y = litval(y)
opcode = opcode+y&255
->next
s(rel):
->s(mquick) if y <= 0 and y >= litmite
s(longrel):
->simm if y <= 0
dy_flags = dy_flags!rflag
extword = dy_val
f = 0
pcrel(longrel-kind&31)
store(extword,f)
->next
s(ireg): !immediate or dreg (BTST etc)
if y > 0 start
! %if size # 0 %start
! %if modex&2_111000 = 0 %start
! fault(sizerr) %if size # 4
! %else
! fault(sizerr) %if size # 1
! %finish
! %finish
->sreg
finish
opcode = opcode!!16_900
y = litval(y)
if modex&2_111000 # 0 and size > 1 start {2nd not reg, not byte}
adjustment = size
adjustment = adjustment-1 and y = y-8 until y < 0
y = y+8
modex = modex+(dispmode-indirmode) if adjustment # 0 -
and modex&2_111000 = indirmode
finish
store(y,0)
-> next
s(imm):
simm:
y = litval(y)
store(y>>16,0) if size = 4
put:
store(y,0)
->next
s(ximm): !MOVEM (IMM,EA or EA,IMM)
if y > 0 start ; !EA,IMM
opcode = opcode!!16_0400
i = x; x = y; y = i
dx == dy; modex = mode
finish
y = litval(y)
if prea0 <= x <= prea7 start ; !-(SP)
i = 0; !Reverse bits
i = i<<1+y&1 and y = y>>1 for extword = 1,1,16
y = i
finish
->put
s(data):
opcode = dy_val
->next
s(*):
err:
fault(moperr)
->next
end ; !plant
routine PLANTLIT(integer op,v,x)
if v >= 0 start
if v <= smallmax start
plant(op,-(v<<1),x)
return
finish
else
if v >= smallmin start
plant(op,v<<1+1,x)
return
finish
finish
litstore(litmax) = v; plant(op,litmax,x)
end
routine PLANTLIT2(integer op,y,v)
if v >= 0 start
if v <= smallmax start
plant(op,y,-(v<<1))
return
finish
else
if v >= smallmin start
plant(op,y,v<<1+1)
return
finish
finish
litstore(litmax) = v; plant(op,y,litmax)
end
routine ALIGN(integername AD, integer size)
!Impose alignment requirements on address AD for
! operand of length SIZE
!provisional basis for bit addressing
! -- multiples of 16 on Word boundary
! -- multiples of 8 on Byte boundary
! -- other < 32 within one Longword
!%constinteger BITMASK=16_E0000000
! %if size&7 = 0 %start
! ad = (ad&(\bitmask))+1 %if ad&bitmask # 0; !ensure on byte boundary
! %return %if size&8 # 0
! %else
! %return %if size < 16
! %return %if ad>>29+(ad&1)<<3+size <= 32
! ad = (ad&(\bitmask))+1 %if ad&bitmask # 0
! %finish
ad = ad+1 if ad&1 # 0 and size # 1
end
routine FORGET(integer r)
c_reg_content(r) = undef if r <= maxareg
end
routine REMEMBER(integer r,v)
c_reg_content(r) = v if r <= maxareg
c_reg_part = c_reg_part&(\(16_0101<<(r-d0))) if r < a0
end
routine PARTSET(integer r,s)
if s = 1 then c_reg_part = c_reg_part!16_0101<<(r-d0) -
else c_reg_part = c_reg_part!1<<(r-d0)
end
routine ADDIMM(integer bytes,dest)
if bytes <= 0 start
return if bytes = 0
if bytes >= -8 start
plantlit(sub,-bytes,dest)
return
finish
else if bytes <= 8
plantlit(add,bytes,dest)
return
finish
if a0 <= dest <= a7 and is short(bytes) start
plant(lea,tempd(dest,bytes),dest)
return
finish
plantlit(add,bytes,dest)
end
integer fn FREE REG(integer rset)
integer r,r1
r = d0; rset = rset&free
if rset = 0 then fault(plexerr) else start
r = r+1 and rset = rset>>1 while rset&1 = 0
r1 = r
while c_reg_content(r) # undef cycle
r = r+1; rset = rset>>1
r = r1 and exit if rset = 0
r = r+1 and rset = rset>>1 while rset&1 = 0
repeat
free = free-1<<(r-d0)
finish
result = r
end
routine MOVE BLOCK(integer source,dest,bytes)
!Generate code to move a fixed number of bytes
! from SOURCE (0,reg,pre,post) to DEST (pre,post)
! -- source & dest addresses both even if BYTES even
integer op,f,r,pc1
op = move; op = clr if source = 0
if bytes <= 16 and bytes&1 = 0 start
plant(op,source,dest) and bytes = bytes-4 while bytes >= 4
plant(op+2<<8,source,dest) if bytes >= 2
else ; !use loop
op = op+1<<8
if bytes&1 = 0 start
bytes = bytes>>1; op = op+1<<8; !.B -> .W
if bytes&1 = 0 start
bytes = bytes>>1; op = op+2<<8; !.W -> .L
finish
finish
f = free
if bytes <= 32768 and free&(anydreg-bregb) # 0 start
r = free reg(anydreg-bregb)
plantlit(move,bytes-1,r)
pc1 = pc
plant(op,source,dest)
plantlit2(dbra,r,(pc1-pc-1)<<1)
else
r = free reg(anydreg)
plantlit(move,bytes,r)
pc1 = pc
plant(op,source,dest)
plant(sub,one,r)
plantlit2(bne,0,(pc1-pc-1)<<1)
finish
forget(r) {not worth noting}
free = free!1<<(r-d0)
finish
end
routine UPDATE SP
return if c_val = 0
if c_val < 0 start
addimm(-c_val,a7); c_sp = c_sp-c_val
else
if control&assmask = 0 then addimm(-c_val,a7) {no unass check} c
else move block(d7,prea7,c_val)
extend stack(c_val)
finish
c_val = 0
end
integer fn LOWER(integer t)
record (identinfo)name tp
tp == dict(t)
result = 0 if tp_type = t # inttype {enum}
result = minint if tp[1]_mode # litmode
result = tp[1]_val
end
integer fn UPPER(integer t)
record (identinfo)name tp
tp == dict(t)
result = tp_size if tp_type = t # inttype {enum}
result = maxint if tp[2]_mode # litmode
result = tp[2]_val
end
integer fn spec size(integer t)
integer fn NSIZE(record (identinfo)name dp)
result = 4 if dp_flags&(name+indirect) # 0
result = 0 if dp_flags&proc # 0; ![??]
result = size(dp_type)
end
routine GET ARRAY INFO(record (identinfo)name atp,
integer name size,lo,hi)
size = nsize(atp)
lo = lower(atp_xtype); hi = upper(atp_xtype)
end
integer fn SIZE(integer t)
!Storage size for given object type in bytes
! > 0 for operand passable in register
! < 0 otherwise
integer s,ss,lo,hi
record (identinfo)name tp
tp == dict(t)
if tp_flags&nonord = 0 start
result = |tp_size| if tp_type # t; !subrange
result = 4 if tp_type = inttype
result = 1 if tp_size <= 255
result = 2
finish
result = tp_val if tp_flags&cat = recy
result = tp_size if tp_flags&cat # arry
result = 0 if tp_mode >= framemode; !dynamic bounds
get array info(tp,s,lo,hi)
result = 0 if lo = minint or hi = maxint
ss = (hi-lo+1)*s
result = ss if ss <= 0
if s = 1 start ; !byte element size (not nec aligned)
result = ss if ss = 1
else ; !word,long element size (aligned)
result = ss if ss <= 4
finish
result = -ss
end
integer fn REPSIZE(integer t)
!Representation/size for loadable object of type T
! > 0 for signed, < 0 unsigned
record (identinfo)name tp
tp == dict(t)
result = size(t) if tp_flags&nonord # 0 {not ordinal}
result = tp_size if tp_type # t; !subrange
result = 4 if tp_type = inttype
! Enumeration
result = -1 if tp_size <= 255 {unsigned byte}
result = 2 {short - better than half}
end
integer fn TSIZE(integer x)
result = 4 if x <= 0 or x >= explim
result = size(dict(x)_type)
end
routine FORGET CC
c_reg_ccy = undef
end
routine FORGET REGS
short name cc==c_reg_content(maxareg)
cycle
cc = undef
exit if cc == c_reg_content(d0)
cc == cc[-1]
repeat
c_reg_ccy = undef; c_reg_line = -9
end
routine FORGET TRIPLES
litpos = litmin; explo = explim; oldexplo = explim
end
routine FORGET ALL
integer i,j
record (contentinfo)name lr
forget regs
j = dictlim
cycle
j = j+1
exit if j >= curlab
lr == lreg(j-dictlim)
lr_content(i) = undef for i = d0,1,maxareg
lr_ccx = undef
repeat
forget triples
end
routine DEFINE JUMPS(integer chain)
integer i,j,k
chain = -chain
return if chain <= 0; !no jumps to this label
c_forward = c_forward-1; c_access = 1
cycle
i = prog(chain)
if pflag(chain) = jump start ; !shortenable
j = chain-pflag(chain-1); !adjusted jump position
k = (pc-c_shorts-j)<<1; !displacement
if k > 2 and k <= 127 start
if c_shorts = 255 start
zaps = zaps+100
else
c_shorts = c_shorts+1; shorts = shorts+1
pflag(chain) = shortjump
j = chain
cycle
pflag(j) = pflag(j)+1 if pflag(j) >= zeroshorts
j = j+1
repeat until j = pc
finish
finish
finish
prog(chain) = pc
chain = i
repeat until chain <= 0
end
routine SAVE CONTEXT(integer l)
!Store register content associated with label L
! (prior to generating forward branch)
integer r
record (contentinfo)name lr
return if l-dictlim < 0 {user label}
lr == lreg(l-dictlim)
if dict(l)_val >= 0 start ; !first jump to this label
dict(l)_val = 0
lr = c_reg
c_forward = c_forward+1
else
lr_part = lr_part!c_reg_part
for r = d0,1,maxareg cycle
lr_content(r) = undef if lr_content(r) # c_reg_content(r)
repeat
lr_ccy = undef if lr_ccx # c_reg_ccx or lr_ccy # c_reg_ccy
lr_line = -9 if lr_line # c_reg_line
finish
end
routine SRCALL(integer x)
routine PUT PRIM(record (identinfo)name DX)
!<
!* PRIMGEN marker 3
const short array PRIMCODE(1:403) <-
16_1541,16_7272,16_6179,16_2062,16_6F75,16_6E64,16_7320,16_6578,
16_6365,16_6564,16_6564,16_B098,16_6E06,16_9098,16_6C10,16_D0A0,
16_41FA,16_FFDE,16_2400,16_7202,16_7076,16_4EF8,16_3EFA,16_4A58,
16_660C,16_4840,16_4A40,16_6610,16_4840,16_C0D8,16_4E75,
16_2F01,16_2200,16_C2E8,16_FFFE,16_6008,16_2F01,16_2200,16_4840,
16_C2D0,16_4841,16_C0D8,16_D081,16_221F,16_4E75,
16_1355,16_6E61,16_7373,16_6967,16_6E65,16_6420,16_7661,16_7269,
16_6162,16_6C65,16_660C,16_41FA,16_FFE8,16_7201,16_7058,16_4EF8,
16_3EFA,16_4E75,
16_0F49,16_6E76,16_616C,16_6964,16_2061,16_6464,16_7265,16_7373,
16_6E0C,16_41FA,16_FFEC,16_7201,16_7058,16_4EF8,16_3EFA,16_4E75,
16_1553,16_7461,16_636B,16_2073,16_7061,16_6365,16_2065,16_7868,
16_6175,16_7374,16_6564,16_D88F,16_B8AD,16_017C,16_620E,16_4284,
16_41FA,16_FFDE,16_7203,16_7055,16_4EF8,16_3EFA,16_4284,16_4E75,
16_1741,16_7272,16_6179,16_2062,16_6F75,16_6E64,16_7320,16_696E,
16_7369,16_6465,16_206F,16_7574,16_9282,16_6F0C,16_41FA,16_FFE2,
16_7203,16_7055,16_4EF8,16_3EFA,16_4481,16_5281,16_4EF8,16_3EF4,
16_4E75,
16_0E53,16_7472,16_696E,16_6720,16_746F,16_6F20,16_6269,16_6780,
16_4281,16_1211,16_9001,16_6504,16_9010,16_640C,16_41FA,16_FFE2,
16_7203,16_7051,16_4EF8,16_3EFA,16_1018,16_670C,16_D111,16_1398,
16_1801,16_5201,16_5300,16_66F6,16_2049,16_4E75,
16_3F00,16_7001,16_1E80,16_204F,16_548F,16_4E75,
16_124E,16_6F20,16_7370,16_6163,16_6520,16_666F,16_7220,16_6172,
16_7261,16_7980,16_5680,16_E480,16_E588,16_6D0E,16_204F,16_91C0,
16_90FC,16_0100,16_B1ED,16_017C,16_620E,16_2400,16_41FA,16_FFD2,
16_7201,16_7072,16_4EF8,16_3EFA,16_205F,16_E488,16_6004,16_4840,
16_2F07,16_51C8,16_FFFC,16_4840,16_51C8,16_FFF4,16_4ED0,16_4E75,
16_1149,16_6E76,16_616C,16_6964,16_2025,16_666F,16_7220,16_6C6F,
16_6F70,16_2F00,16_9082,16_6720,16_2F01,16_6708,16_4EB8,16_3EEE,
16_4A80,16_6D0E,16_508F,16_41FA,16_FFD8,16_7201,16_7055,16_4EF8,
16_3EFA,16_4A81,16_66EE,16_221F,16_201F,16_4E75,
16_0C4F,16_7574,16_206F,16_6620,16_7261,16_6E67,16_6580,16_41FA,
16_FFF0,16_7201,16_7056,16_4EF8,16_3EFA,16_4E75,
16_1355,16_6E61,16_7373,16_6967,16_6E65,16_6420,16_7661,16_7269,
16_6162,16_6C65,16_B0FC,16_0000,16_6F1A,16_B2FC,16_0000,16_6F14,
16_BE10,16_6606,16_BE28,16_0001,16_670A,16_BE11,16_6612,16_BE29,
16_0001,16_660C,16_41FA,16_FFCA,16_7202,16_7054,16_4EF8,16_3EFA,
16_48E7,16_C0C0,16_4240,16_1018,16_6730,16_4241,16_1219,16_6722,
16_5380,16_5381,16_B041,16_6E12,16_9240,16_B109,16_56C8,16_FFFC,
16_6602,16_4441,16_4CDF,16_0303,16_4E75,
16_B109,16_56C9,16_FFFC,16_66F2,16_7201,16_4CDF,16_0303,16_4E75,
16_1011,16_4440,16_4CDF,16_0303,16_4E75,
16_0E53,16_7472,16_696E,16_6720,16_746F,16_6F20,16_6269,16_6780,
16_B010,16_640C,16_41FA,16_FFEA,16_7203,16_7051,16_4EF8,16_3EFA,
16_4280,16_1010,16_12D8,16_51C8,16_FFFC,16_4E75,
16_0E53,16_7472,16_696E,16_6720,16_746F,16_6F20,16_6269,16_6780,
16_B010,16_640C,16_41FA,16_FFEA,16_7201,16_7056,16_4EF8,16_3EFA,
16_0240,16_00FE,16_221F,16_9EC0,16_558F,16_224F,16_BFC8,16_6F10,
16_1018,16_5289,16_D0C0,16_D2C0,16_1320,16_51C8,16_FFFC,16_6008,
16_1010,16_12D8,16_51C8,16_FFFC,16_204F,16_224F,16_2F01,16_4E75,
16_4A80,16_6F1C,16_B210,16_6218,16_43F0,16_1801,16_9280,16_6D10,
16_204F,16_2001,16_1121,16_51C9,16_FFFC,16_5280,16_1100,16_4E75,
16_41FA,16_0000,16_4E75,
16_700A,16_4EF8,16_3E70,16_4E75,
16_7020,16_4EF8,16_3E70,16_4E75
!<
integer start,limit
record (identinfo)name DDX
fill code(1) if cad&1 # 0
start = dx_val>>16&511; limit = start+dx_val&255
dx_val = cad+dx_val>>7&(255<<1); !entry
dx_mode = procmode
if start = limit start ; !range check
ddx == dict(check)
put prim(ddx) and dx_val = cad if ddx_mode = absmode
set code word(16_0C80); !CMPI.L #?,D0
set code longword(dx[1]_val); !lower
set code word(16_6D00); !BLT
set code word(ddx_val-cad)
set code word(16_0C80); !CMPI.L #?,D0
set code longword(dx[2]_val); !upper
set code word(16_6E00); !BGT
set code word(ddx_val-cad)
set code word(16_4E75); !RTS
else
set code word(primcode(start)) and start=start+1 until start >= limit
finish
end
record (identinfo)name dx==dict(x),tp==dict(dx_type)
if dx_mode = absmode and dx_val < 0 start ; !prim routine
![**for now**: the convention is inadequate because excludes abs neg]
put prim(dx)
else
c_status = c_status!unknown if tp_val <= 0
c_totstack = c_sp-|tp_val| if c_sp-|tp_val| < c_totstack
finish
if dx_mode&63 = pcmode start ; !internal
c_forward = c_forward+1 if dx_flags&spec # 0 and dx_flags&rflag = 0
plant(bsr,0,x)
else
plant(jsr,0,x)
finish
end ; !srcall
!
routine DEFINE LABEL(integer lab)
integer r,chain
record (contentinfo)name lr
chain = dict(lab)_val
if chain >= 0 start ; !label before jumps
update sp
forget regs
else
lr == lreg(lab-dictlim)
if c_access = 0 start ; !no fall-through
c_reg = lr; !so just incoming context
else ; !join
c_reg_part = c_reg_part!lr_part
for r = d0,1,maxareg cycle
forget(r) if c_reg_content(r) # lr_content(r)
repeat
forget cc if c_reg_ccx # lr_ccx or c_reg_ccy # lr_ccy
c_reg_line = -9 if lr_line # c_reg_line
finish
finish
define jumps(chain)
dict(lab)_val = pc
{?} put operand(lab) if control&codelist # 0 and control&list # 0
end ; !define label
routine SET USER LABEL(integername chain)
update sp
addimm(c_temps,a7) if c_temps # 0 and c_access # 0 {remove temps}
define jumps(chain)
chain = pc
c_access = 1; !anyway
addimm(-c_temps,a7) if c_temps # 0 {restore temps}
forget regs
forget triples if curlab = c_lab1
end
routine FLUSH
if pendcond < 0 start ; !indicator for line num update
litstore(litpos) = line
if control&tracebit # 0 then plantlit2(trapi,litpos,15) c
else if line-c_reg_line > 8 then plant(move+2<<8,litpos,lineloc) c
else plantlit(add+2<<8,line-c_reg_line,lineloc)
forget cc; c_reg_line = line
else
if pendout # 0 start
pendcond = pendcond&15
c_access = 0 if pendcond = 0
if pendcond # 1 start
save context(pendout)
plant(bra+pendcond,0,pendout)
finish
finish
define label(pendin) if pendin # 0
finish
pendcond = 0
end
!!!!!!!!!!!!!!!! Main code generation procedure !!!!!!!!!!!!!!!!!!!!!
constinteger INST=1<<30
routine EVAL(integername pp, integer rset)
!Evaluate the operand identified by PP as defined by RSET:
! RSET = boolean vector of acceptable registers
! + SIGN to indicate that stopping at EA is acceptable
! + 1<<16 to indicate only 8 bits needed
! + 2<<16 to indicate only 16 bits needed
! + STACK if stack ok [not fully yet: too complex]
constinteger VAL=sign+anyreg, DVAL=sign+anydreg, REF=sign,
SIZESHIFT=16,
TO8=1<<sizeshift, TO16=2<<sizeshift, {4 not sig}
TOSTACK=1<<19, ASAD=1<<20, MOD=1<<21
constinteger ASL=32,
CMPM=43,
TRAPV=70,
SWAP=74, EXTL=76,
JMP=57, TST=59, DBNE=86, BTST=99
constinteger MOVEW=move+2<<8, ADDW=add+2<<8,
MOVEB=move+1<<8, ADDB=add+1<<8,
SUBB=sub+1<<8, CMPB=cmp+1<<8,
CMPMB=cmpm+1<<8
switch DO(0:opmax)
owninteger STSIZ=0; !this variable is used to convey a
!rarely required 3rd parameter to EVAL
!Its value is captured into STSIZE on entry
!A negative value indicates a string;
! a positive value a fixed length structure
! * CF normal use of negative/positive size *
integer I,J,P,ACT,X,Y,XX,YY,WX,WY,SX,SY,R,OLDFREE,FREED
integer M,V,SP,STSIZE,OP,CASE
record (identinfo)name DP,DX,DY,TX
integer fn FREE DREG
result = free reg(anydreg-bregb)
end
integer fn FREE AREG(integer content)
integer r
r = free reg(anyareg)
c_reg_content(r) = content
result = r
end
routine PUSH(integer x)
plant(move,x,prea7); extend stack(4)
end
routine POP(integer x)
plant(move,posta7,x); c_sp = c_sp+4
end
routine PUSHS(integer x,s)
s = s&3
plant(move+s<<8,x,prea7)
if s # 0 then extend stack(2) else extend stack(4)
end
routine PUSH BLOCK(integer areg,bytes)
if bytes <= 4 then move block(areg+indir,prea7,bytes) c
else addimm(bytes,areg) and move block(areg+pre,prea7,bytes)
extend stack(bytes)
end
routine COMPILE UNCOND BRANCH(integer l)
if pendcond # 0 start
if pendcond < 0 start
pendcond = 0; !ok?
else if pendin # 0
flush; ![safe - improvable?]
else
pendcond = pendcond!!1
c_access = -2 if pp+1 < np and dict(pp+1)_act = else
finish
finish
pendcond = pendcond&15
c_access = 0 if pendcond = 0
plant(bra+pendcond,0,l) if pendcond # 1
pendcond = 0
end
integer fn CLEAN REG
integer r
free = free-bregb and result = breg if free&bregb # 0
r = free dreg
plant(clr,0,r)
result = r
end
integer fn WEIGHT(integer p)
!(Heuristic: can't anticipate all generation decisions)
integer a,wy
record (identinfo)name dp
p = p-ad if p >= explim
result = 1 if p < np0
dp == dict(p)
a = dp_act
result = 1 if a < 0
result = 999 if a >= imul; !funcall,mapcall
wy = weight(dp_y)
result = wy if wy >= 999
result = wy+weight(dp_x)
end
routine CHECK ADDRESS(integer v)
if a0 <= v <= a7 then plant(cmp+2<<8,0,v) else plant(tst,0,v)
srcall(adok)
forget cc
end
!!!!!!!!!!!!!!!!!!! Procedure call !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! _____ACT_________X__________Y____
! P -> | procident | param 1 | param 2 |
! | 0 | param 3 | param 4 |
! . . . .
!
routine CALL
!Load parameters following P and call procedure ACT (DX)
! Update PP for RCALL
integer sp,stage,maxq
routine EVAL PARLIST(integer arg,q)
record (identinfo)name darg,dv
integer v,w,f,r,s
return if arg = 0
darg == dict(arg)
q = q+1; maxq = q if q > maxq
if q&1 = 0 then v = dict(p+q>>1)_x else v = dict(p+q>>1)_y
r = darg_reg&15; s = size(darg_type)
if darg_val > 0 start ; !passed on stack
eval parlist(darg_link,q)
return if stage # 0
if darg_flags < 0 start ; !name
f = free
! eval(v,ref)
! plant(pea,0,v); extend stack(4)
eval(v,anyareg)
push(v)
free = f
return
finish
if s > 0 start ; !simple value
f = free; eval(v,val)
pushs(v,s)
free = f
else ; !structure by value
stsiz = s
stsiz = -stsiz if category(darg_type) # stringy
eval(v,tostack)
finish
return
finish
if s <= 0 and darg_flags >= 0 start
!structure by value -- ad in reg
v = v-ad if v >= explim
if v >= np0 start ; !actual is complex
dv == dict(v)
if dv_act >= concat and dv_mode = 0 start
!string/record function
if stage = 0 start
stsiz = s
stsiz = -stsiz if category(darg_type) # stringy
r = v; eval(r,tostack)
free = free!a0b; ![?here?]
remember(a0,v+ad)
dv_val = c_sp
eval parlist(darg_link,q)
else
eval parlist(darg_link,q)
if c_reg_content(r+d0) # v+ad start
dv_mode = c_mode
plant(lea,v,r+d0)
dv_mode = 0
finish
free = free&(\(1<<r))
finish
return
finish
finish
v = v+ad
finish
w = weight(v)
if w >= 999 start
eval parlist(darg_link,q)
return if stage # 0
else
if w >= 2 and stage # 0 start
eval(v,1<<r)
eval parlist(darg_link,q)
return
finish
eval parlist(darg_link,q)
return if stage = 0
finish
eval(v,1<<r)
end
push(mb) if dx_flags&proc2 # 0 c
and (dx_flags&ext = 0 or dx_flags&spec # 0); !param or external
sp = c_sp
maxq = 0
stage = 0
eval parlist(dict(dx_type)_link,-1)
stage = 1
eval parlist(dict(dx_type)_link,-1)
srcall(act)
if c_sp # sp start
addimm(sp-c_sp,a7); c_sp = sp
finish
pop(mb) if dx_flags&proc2 # 0 c
and (dx_flags&ext = 0 or dx_flags&spec # 0)
pp = p+maxq>>1 if p < np; !update for RCALL + RESOL
forget regs
c_reg_line = line if dx_flags&(ext+proc) = ext+proc1; !%system
end ; !call
!
routine STRUCTCALL(integer entry,size)
size = mite(-size-1) and forget(breg) if size <= 0; !string
plantlit(move,size,d0)
srcall(entry)
forget(d0)
end
routine PUSH STRUCTURE
if stsize <= 0 start ; !string
structcall(strtostk,stsize)
forget(a0); forget(a1); forget(a0+2)
extend stack(256-(stsize&254))
else ; !fixed size structure
push block(a0,(stsize+1)&(\1))
finish
end
routine COPY(integer name r,integer to)
integer s=0
if r < a0 -
and c_reg_part&1<<(r-d0) # 0 start {part reg}
s = 2
s = 1 if c_reg_part&16_0100<<(r-d0) # 0
finish
remember(to,pp)
if to < a0 start
partset(to,s) if s # 0
c_reg_ccx = pp; c_reg_ccy = 0
finish
plant(move+s<<8,r,to)
r = to
end
routine OK AREG(integer got,ok)
r = got
if 1<<(got-d0)&ok = 0 start
r = free reg(ok); plant(move,got,r)
finish
end
routine LOAD ADDRESS(integer p)
integer i,f
if rset&anyareg&free # 0 start
if dp_mode&2_111000 = indexmode and dp_val&255 = 0 start
i = a0b<<(dp_mode&7)
rset = i if rset&free&i # 0
finish
r = free reg(rset&anyareg)
plant(lea,p,r)
else
f = free
i = free areg(p+ad); plant(lea,p,i)
free = f
r = free reg(rset&(\bregb)); plant(move,i,r)
finish
end
routine COMMANDEER(integer regs)
integer r
freed = \free®s
if freed # 0 start
regs = freed; r = d0
while regs # 0 cycle
push(r) and forget cc if regs&1 # 0
regs = regs>>1; r = r+1
repeat
free = free!freed; rset = rset&(\freed)
finish
end
routine RESTORE(integer regs)
integer r
r = a7
while regs # 0 cycle
if regs&16_8000 # 0 start
pop(r); forget(r); !*should have remembered it*
forget cc
finish
regs = regs<<1&16_FFFF; r = r-1
repeat
end
integer fn LCR(integer t1,t2)
!Lowest common representation size for loadable types T1 and T2
integer r1=repsize(t1), r2=repsize(t2)
result = r1 if r1 = r2
if r1 < r2 start
result = r2 if r1 > 0 {both signed: max}
result = r1 if r2 < 0 {both unsigned: min}
result = r2 if r2 > |r1| {R2 signed, R1 unsigned}
result = |r1|<<1
else
result = r1 if r2 > 0 {both signed: max}
result = r2 if r1 < 0 {both unsigned: min}
result = r1 if r1 > |r2| {R1 signed, R2 unsigned}
result = |r2|<<1
finish
end
routine PARTREG
! Something smaller than integer has been loaded to R
! Determine what else to do (using SX,SY)
while |sy| < sx cycle
if sy > 0 start ; !signed
plant(extl-2+sy,0,r); !ext.w,ext.l
sy = sy+sy
else
if sy = -1 start ; !unsigned byte
plantlit(and+sx<<8,255,r)
else ; !unsigned word (half)
plantlit(and,16_FFFF,r)
finish
sy = sx
finish
repeat
end
!!Start of EVAL
stsize = stsiz; !additional parameter (for TOSTACK cases)
p = pp; p = p-ad if p >= explim
rset = rset-asad and pp = p+ad if rset&asad # 0
if p <= 0 then dp == dint else dp == dict(p)
rset = rset&(\anyareg) if rset&to8 # 0
rset = rset&free if rset&mod # 0
oldfree = free; freed = 0
if rset # inst start
unless dp_mode&2_110000 = 0 and p < np0 start ; !not already reg
r = pp
if rset&(anydreg{+tostack}) # 0 start ; !data reg acceptable
i = d0
cycle ; !See if available
r = i and exit if c_reg_content(i) = r
i = i+1; i = a0 if i = maxdreg+1
repeat until i > maxareg
else if rset&anyareg # 0; !try address regs first
i = maxareg
cycle
r = i and exit if c_reg_content(i) = r
i = i-1; i = maxdreg if i = a0-1
repeat until i < d0
else if r < explim and rset # tostack; !REF: try for address
i = a0
cycle
if c_reg_content(i) = r+ad start
free = free&(\(1<<(i-d0)))
dp_flags = dp_flags!(rflag+wflag)
pp = i+indir
return
finish
i = i+1
repeat until i > maxareg
finish
else ; !already reg
r = dp_mode+d0; !in case reg alias
if dp_flags >= 0 start {value}
fault(nonref) if pp >= explim {address wanted}
else if pp < explim {indirect value wanted}
r = r+indir
p = r and -> fetch if rset >= 0
finish
pp = r and return if rset = ref
finish
if 0 < r <= a7 start ; !operand (in) reg
dp_flags = dp_flags!rflag
if r < a0 and c_reg_part&1<<(r-d0) # 0 start {partreg}
sx = rset>>sizeshift&3; sx = 4 if sx = 0
sy = 2; sy = 1 if c_reg_part&16_0100<<(r-d0) # 0
if sy < sx start
sy = -sy if repsize(dp_type) = -sy {unsigned,not extended}
c_reg_ccx = pp; c_reg_ccy = 0
partreg
c_reg_part = c_reg_part&(\(16_0101<<(r-d0)))
c_reg_part = c_reg_part&(\(1<<(r-d0))) if sy = 4
finish
finish
-> endinr
finish
if p <= 0 start ; !literal
return if rset < 0
if rset = tostack start
i = constmode; i = pcmode if p = 0; !null string [sneaky]
plant(lea,temp(i,litval(p)),a0); !A0 must be free
forget(a0)
push structure
return
finish
if pp < explim start ; !normal value
rset = rset&(\bregb) if p < -(255<<1) or p&1 # 0; !0:255 ok
r = free reg(rset)
if r < a0 or p # 0 then plant(move,p,r) c
else plant(sub,r,r)
else ; !address within FINAL
i = constmode; i = pcmode if p = 0; !null string [sneaky]
load address(temp(i,litval(p)))
finish
c_reg_ccx = pp and c_reg_ccy = 0 if r < a0
sy = 4
->endload
finish
finish
if p >= np0 start ; !complex
more:
act = |dp_act|; x = dp_x; y = dp_y
xx = x; yy = y
-> proccall if act > opmax
-> do(act)
finish
do(move):
load:
i = 0
i = i+1 if dp_flags&indirect # 0
i = i+2 if dp_flags < 0
if pp >= explim start {address wanted}
if i = 0 start
free = oldfree
load address(p)
else
if i = 3 start {indirect name}
free = oldfree
r = free areg(undef); plant(move,p,r)
p = r+indir
finish
pp = p and return if rset < 0
free = oldfree
r = free reg(rset&(\bregb)); plant(move,p,r)
finish
c_reg_ccx = pp and c_reg_ccy = 0 if r < a0
sy = 4
else {value wanted}
if i > 0 start {indirection needed}
free = oldfree
r = maxareg+1
cycle
r = r-1
if r < a0 start
r = free areg(p+ad)
plant(move,p,r) {direct move}
plant(move,r+indir,r) if i = 3
check address(r) if i > 1 and control&assbit # 0
exit
finish
repeat until c_reg_content(r) = p+ad
free = free&(\(1<<(r-d0)))
p = r+indir
finish
fetch:
pp = p and return if rset = ref
sx = rset>>sizeshift&3; sx = 4 if sx = 0
sy = size(dp_type)
i = dp_flags
if c_localdpos <= p < dlim and i&okflag = 0 and c_forward = 0 start
!local, simple, always accessed
if i&wflag = 0 start ; !unassigned
report(asserr+warn,p,0) if c_faults = 0
finish
dp_flags = dp_flags+okflag if dp_flags >= 0 and sy > 0
finish
if rset = tostack start
free = oldfree
plant(lea,p,a0); !A0 must be free
forget(a0)
push structure
return
finish
intern(5) and return if sy <= 0
i = i!okflag if control&bassbit>>1<<sy = 0
if i&okflag # 0 and rset < 0 start ; !not necessary to load?
if sy = sx start ; !same size
pp = p
return
finish
finish
free = oldfree
if i&okflag # 0 then i = -1 else i = sy
sy = repsize(dp_type) {neg if UNsigned}
if sy = -1 start ; !unsigned byte
if free&bregb # 0 start
if rset&bregb # 0 start
rset = bregb
else
plant(moveb,p,breg)
forget(breg)
p = breg; sy = 4
finish
finish
finish else rset = rset&(\bregb)
if sy < 2 or sx = 1 start
! Source unsigned or byte, or target 8 bits
if rset&anydreg = 0 start
!Can't load bytes,mites,halfs to address regs
! or store bytes from them
r = free dreg
plant(move+|sy|<<8,p,r)
partreg
p = r; free = oldfree
finish else rset = rset&(\anyareg)
finish
if sy = 2 and rset&anyareg&free # 0 start
rset = rset&anyareg; !prefer areg for word (auto-extend)
finish
r = free reg(rset)
if r < a0 start
if sy < 0 and |sy| < sx and r # breg -
and dict(p)_mode # r-d0 -
and (dict(p)_mode&2_111000 # indexmode or dp_val>>12&15 # r-d0) start
plant(clr,0,r)
plant(move+|sy|<<8,p,r); sy = 4
else
plant(move+|sy|<<8,p,r); sy = 4 if r = breg
finish
c_reg_ccx = pp; c_reg_ccy = 0
partreg if sy # 4
else
plant(move+|sy|<<8,p,r); sy = 4
finish
if i >= 0 start {unassigned check required}
plant(cmp+i<<8,r,d7)
srcall(unass)
forget cc
finish
finish
endload:
remember(r,pp)
partset(r,sy&3) if sy&3 # 0
endload1:
free = free&(\(1<<(r-d0)))
r = r+indir if rset = ref
pp = r
return
dataload:
eval(p,anydreg-bregb)
r = p
!The operand has been evaluated into a (full) register
endloadr:
free = oldfree
remember(r,pp)
!The operand is in a register: is it ok?
endinr:
if rset&1<<(r-d0) = 0 and rset # ref start {not ok}
if rset&free = 0 and rset&tostack # 0 start
push structure; r = a7
! push(got); r = a7
! c_reg_ccx = pp; c_reg_ccy = 0
else
copy(r,freereg(rset&(\bregb)))
finish
finish
restore(freed)
-> endload1
!!!!!!!!!!!!!!!! Array / Record / Map !!!!!!!!!!!!!!!!!!
routine ADEVAL(integer x,y,q)
!Base X, scaled index Y, displacement Q
integer i,j
routine LOAD AREG(integer xx,for)
!Use the register component of M if alterable
! to avoid excessive dissipation of address registers
integer i
i = m&7
if oldfree&a0b<<i = 0 or m > indexmode+7 start
! Areg component not free or not Areg component
i = free areg(for)
else
free = free&(\(a0b<<i))
i = i+a0; remember(i,for)
finish
return if xx = x and m = i+(dispmode-a0) and v = 0
plant(lea,xx,i)
m = i+(dispmode-a0); v = 0
end
if x <= 0 start ; !%const
m = constmode; v = litval(x)
else
eval(x,ref)
m = dict(x)_mode; v = dict(x)_val
if m = c_mode and v < 0 start
!*Assertion: SP will have same value when address used
m = dispmode+7; v = v-c_sp
else if m&2_111000 = indirmode
m = m+(dispmode-indirmode)
finish
finish
eval(y,anyreg) if y # 0; !subscript
if m&2_111000 = indexmode start ; !X already involves index
if y = 0 start
!See if Q can be combined with existing disp
j = mite(v)
i = j+q
if is mite(i) start
v = v-j+i&255
return
finish
finish
load areg(x,x+ad)
finish
if y # 0 start
if m&63 = pcmode start
load areg(temp(m,v+q),undef)
q = 0
else if not is mite(v+q); !indexmode out
if not is mite(q) start ; !& out even if V absorbed
if is short(v+q) start
load areg(temp(m,v+q),undef)
else
load areg(x,undef)
addimm(q,m&7+a0)
finish
q = 0
else
load areg(x,x+ad)
finish
finish
finish
v = v+q
if y # 0 start
m = m+(indexmode-dispmode)
v = (y-d0)<<12+16_0800+v&255
finish
end
do(index):
! P => {index,ARRAY,SUBSCRIPT}
! ARRAY => ARRID
! or {index,ARRAY,SUBSCRIPT}
! or {recref,RECORD,ARRAY}
! TYPE INFO : TYPE = ELTYPE, XTYPE = INDEX-TYPE
! MODE,VAL = DOPE ADDRESS
dx == dict(x)
i = dx_type; !array type cell
tx == dict(i)
get array info(tx,m,sx,sy)
m = |m|
!ARRFLAG is set for either ABC requested or dynamic
if dx_flags&arrflag # 0 and (y > 0 or sx = minint or m = 0) start
commandeer(d0b+d1b+a0b); ![D1 ??]
! subscript
eval(y,d0b)
! dope vector
j = 0
j = j+12 and i = i+1 and tx == dict(i) while tx_mode = 0
if tx_flags&indirect # 0 start
plant(move,i,a0)
addimm(j,a0) if j # 0
else
if tx_val = 0 and tx_mode = constmode start
! dope info not yet created
fill code(1) if cad&1 # 0
tx_val = cad
set code longword(sy)
set code longword(sx)
set code longword(m)
finish
plant(lea,i,a0)
finish
srcall(index)
forget(d0); forget(a0)
restore(freed&(\d0b))
free = oldfree&(\d0b)
freed = freed&d0b
i = x; eval(i,anyareg!mod!asad)
plant(add,d0,i)
if dp_flags < 0 then forget(i) {ad of ad of P} c
else remember(i,p+ad)
free = free!d0b if freed = 0
restore(freed); freed = 0
m = i+(dispmode-a0); v = 0
-> setflags
finish
index1:
!deal with subscript
j = 0
if y <= 0 start ; !literal subscript
j = litval(y); y = 0
finish
if y >= np0 and dict(y)_act = add c
and dict(y)_y <= 0 start ; !Y => {add,exp,lit}
j = litval(dict(y)_y); y = dict(y)_x
finish
if m > 1 start
if y # 0 start
i = imul
i = mulop(sx,sy,m,m) if m&(m-1) # 0 {not power of 2}
putexp(i,y,litref(m),inttype)
y = item
finish
finish
if dx_flags&(name+ext+arrflag+indirect) = indirect and sx # 0 start
dx_val = dx_val+4; !0-based
adeval(x,y,j*m)
dx_val = dx_val-4
else
j = j-sx; j = j*m if m > 1
adeval(x,y,j); !array,index,displacement
finish
setflags:
dx_flags = dx_flags!(mflag+wflag+rflag); !don't know
setmode:
![what about FRAMEMODE?]
if dispmode <= m < indexmode start
unless isshort(v) start
ok areg(m+(a0-dispmode),oldfree&anyareg)
addimm(v,r); forget(r)
m = r-(a0-dispmode); v = 0
finish
if pp >= explim and v = 0 and rset # ref and dp_flags >= 0 start
!address wanted, disp zero, as value, not name
! so the address is simply in the register
r = m+(a0-dispmode)
-> endloadr
finish
finish
dp_mode = m; dp_val = v
->load
do(recref):
! P => {recref,RECORD,SUBEL}
dx == dict(x)
adeval(x,0,dict(y)_val); !record,subscript,displacement
->setflags
do(storemap):
v = 0
if y >= explim start
y = y-ad; eval(y,ref)
m = dict(y)_mode; v = dict(y)_val
else
if y >= np0 start
if dict(y)_act = add start
m = dict(y)_y
y = dict(y)_x and v = litval(m) if m <= 0
! eval(y,val) %if y >= dictlim
finish ;! %else eval(y,val)
finish
eval(y,anyareg)
check address(y) if control&assbit # 0 and pp < explim
m = y+(dispmode-a0)
finish
-> setmode
do(lenref):
do(sindex):
x = x-ad if x >= explim
dx == dict(x)
if y <= 0 then adeval(x,0,litval(y)) c
else eval(y,anydreg) and adeval(x,y,0)
-> setflags
do(dnew):
commandeer(c_free)
plant(move,y,d0)
srcall(act)
forget regs
c_reg_line = line
-> endmap
do(dtostring):
proccall:
dx == dict(act)
-> rcall if p < np
-> funcall if dx_flags&writable = 0
!mapcall
commandeer(c_free)
call
endmap:
free = oldfree
r = a0
ok areg(a0,\freed&anyareg) if rset # ref
restore(freed); freed = 0
free = free&(\(1<<(r-d0)))
remember(r,p+ad)
m = r+(dispmode-a0); v = 0; !0(A?)
->setmode
funcall:
commandeer(c_free)
call
r = dict(dx_type)_reg&15+d0
c_reg_ccx = pp and c_reg_ccy = 0 if dx_flags&okflag # 0
->endloadr
rcall:
flush if pendcond # 0
update sp
!<
while act = dprintstr and x >= np0 and dict(x)_act = concat cycle
dp_x = dict(x)_x; !first of pair
call; free = c_free
x = dict(x)_y; dp_x = x
repeat
!<
call
c_access = 0 if dx_flags&noret # 0
forget triples if pp+1 = np and curlab = c_lab1 c
and dict(curlab)_val >= 0 and dict(curlab+1)_val >= 0
return
!!!!!!!!!!!!!!!!!!!!!!!!! Operators !!!!!!!!!!!!!!!!!!!!!!!!!!!
routine EVALXY
commandeer(d0b+d1b)
if 999 > weight(x) < weight(y) start
eval(y,d1b); eval(x,d0b)
else
eval(x,d0b); eval(y,d1b)
finish
end
routine STACKOP(integer s)
stsiz = s
sp = c_sp
eval(x,tostack)
free = free!a0b
eval(y,a0b+asad)
plant(move,a7,a1); !dest (stack)
structcall(act,s)
forget(a0); forget(a1); forget(a0+2)
end
!<
do(prel):
! P => {prel,BASENAME,INDEX}
dx == dict(x)
m = |size(dx_type)|
sx = 0; sy = 999999
-> index1
!<
do(check): !CHECK rangetype,value
commandeer(d0b)
eval(y,d0b)
srcall(x)
r = d0
-> endloadr
routine SWOP
wx = weight(x)
if wx <= 1 and y <= 0 and y >= litmite and rset&(\anyareg) # 0 start
rset = rset&(\anyareg)
i = x; x = y; y = i
else if 999 > wx < weight(y)
i = x; x = y; y = i
finish
end
routine LITYTOREG
!Bring 2nd operand to register if it can be done by MOVEQ
! [since MOVEQ + EA=dreg is shorter than EA=immediate-long]
eval(y,anydreg) if y < 0 and y >= litmite and free&(anydreg-bregb) # 0
end
predicate ISBYTE(integer y)
true if y <= 0 and y >= -510 and y&1 = 0
false
end
![Note that all literal subtraction comes through as ADD]
do(add):
if control&overbit # 0 start
-> dataload if rset&anydreg = 0
rset = rset&anydreg
finish
if y < 0 start
if y >= litquick start ; !(ADDQ,SUBQ)
y = y-1 and act = sub if y&1 # 0; !'negate' if 'negative'
eval(x,rset&free&(\bregb))
oldfree = free
->opv
finish
if y = -(128<<1) start ; !+128
act = sub; y = y+1; !- -128 (MOVEQ)
-> addop
finish
finish
swop
addop:
eval(x,rset&free&(\bregb))
oldfree = free
litytoreg
eval(y,val)
opv:
plant(act,y,x)
endopv:
plant(trapv,0,0) if control&overbit # 0
endop:
free = oldfree
enduop:
pp = x
remember(x,p)
c_reg_ccx = p; c_reg_ccy = 0
if act>>8 # 0 start {part-size added}
forget cc {a bit extreme}
finish
return
do(sub):
if control&overbit # 0 start
-> dataload if rset&anydreg = 0
rset = rset&(\anyareg)
finish
-> addop
do(and):
-> dataload if rset&anydreg = 0
swop
eval(x,rset&free&anydreg)
oldfree = free
litytoreg
if y > d7 start
sy = tsize(y)
if sy <= 2 and (isbyte(yy) or x = breg) start
eval(y,dval+sy<<sizeshift)
act = act+sy<<8
finish else eval(y,dval)
finish else eval(y,dval)
logop:
plant(act,y,x)
-> endop
do(or):
-> dataload if rset&anydreg = 0
swop
rset = rset&(\bregb) if not isbyte(y)
eval(x,rset&free&anydreg)
oldfree = free
litytoreg
! sy = tsize(y)
! eval(y,dval+sy<
! act = act+sy<<8
eval(y,dval)
-> logop
do(eor):
-> dataload if rset&anydreg = 0
swop
eval(x,rset&free&(anydreg-bregb))
oldfree = free
litytoreg
eval(y,anydreg) if y > d7
-> logop
do(lsl): do(lsr):
-> dataload if rset&anydreg = 0
eval(x,rset&free&(anydreg-bregb))
oldfree = free
if y < 0 and y >= litquick start
act = act!!(lsl!!lsr) and y = y-1 if y&1 # 0; !negate if neg
else
eval(y,anydreg)
finish
-> logop
routine SHORTOP
eval(x,rset&free&(anydreg-bregb))
oldfree = free
eval(y,dval+to16)
end
do(muls): do(mulu):
-> dataload if rset&anydreg = 0
shortop
-> opv
do(neg):
if y # 0 start
r = y; y = x; x = r
act = sub
-> do(sub)
finish
do(not):
-> dataload if rset&anydreg = 0
eval(x,rset&free&(anydreg-bregb))
plant(act,0,x)
-> enduop
do(iabs):
-> dataload if rset&anydreg = 0
x = y
eval(x,rset&free&(anydreg-bregb))
plant(move,x,x) if c_reg_ccx # y or c_reg_ccy # 0
plantlit2(bge,0,2)
plant(neg,0,x)
oldfree = free
->endopv
do(fabs):
-> dataload if rset&anydreg = 0
x = y
eval(x,rset&free&(anydreg-bregb))
plantlit(and,16_7FFFFFFF,x)
->enduop
routine DO SHIFT
integer i
i = 0; i = i+1 and j = j>>1 until j&1 # 0
if i = 1 then plant(add,x,x) else start
i = litref(i)
eval(i,anydreg) if i < litquick
plant(asl,i,x)
finish
end
do(imul):
-> dataload if rset&anydreg = 0
rset = rset&(anydreg-bregb)
!Test for power of 2 or pair of powers of 2
if y < 0 start
j = litval(y)
i = j&(j-1)
if i = 0 or i&(i-1) = 0 start
eval(x,rset&free)
oldfree = free
do shift if j&1 = 0
if j # 1 start
plant(move,x,prea7)
free = oldfree
do shift
plant(add,posta7,x)
finish
->endopv
finish
finish
do(fsub): do(fdiv):
do(ipow): do(fpow):
do(fadd): do(fmul):
evalxy
srcall(act)
plant(trapv,0,0) if act = imul and control&overbit # 0
forget(d1); r = d0
forget cc
-> endloadr
do(idiv): do(drem):
if control&halfbit # 0 start
act = divs if act = idiv
do(divs): do(divu):
-> dataload if rset&anydreg = 0
shortop
if act = drem then plant(divs,y,x) and plant(swap,0,x) c
else plant(act,y,x)
plant(extl,0,x)
-> endop
finish
evalxy
srcall(idiv)
putexp(act!!(idiv!!drem),xx,yy,inttype)
if act = idiv start
remember(d1,item); r = d0
else
remember(d0,item); r = d1
finish
forget cc
->endloadr
do(float):
do(fneg):
commandeer(d0b)
eval(x,d0b)
srcall(act)
forget cc
r = d0
->endloadr
do(concat): !not special case
![they have to be free] commandeer(d0b+d1b+a0b+a1b)
fault(plexerr) if free&(a0b+a1b+d0b+d1b) # a0b+a1b+d0b+d1b
stackop(-256)
endconc:
if rset&tostack = 0 start
if c_sp # sp start
addimm(sp-c_sp,a7); c_sp = sp
finish
finish else rset = a0b
r = a0
->endloadr
!!!!!!!!!!!!!!!!!!!!! Conditions !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
routine CONDSWOP
!Swop condition operands, adjusting operator accordingly
integer temp
temp = x; x = y; y = temp
temp = xx; xx = yy; yy = temp
temp = sx; sx = sy; sy = temp
temp = wx; wx = wy; wy = temp
case = case!!3 if case&8 # 0; !no change for '=','#'
end
routine UNSIGNED
if case&8 # 0 start ; !no change for '=','#'
case = case!!8
case = case!!4 if case&2 # 0
finish
end
![Some confusion here of which operand (weightier) to evaluate first
![ and which to bring to register
![EVAL improvements make possible greater finesse:
![ 1. Decide which to evaluate first (weightier)
![ 2. EVAL both 'val'
![ 3. If either in register, OK
![ 4. Load one
![*for IMP, conditions cannot be embedded in other expressions;
![*for Pascal, they can. This needs improvement to cover that.
do(compare):
flush if pendcond # 0
update sp
sp = c_sp
pp = pp+1; dp == dp[1]
case = dp_act
if x <= 0 start ; ![1st literal: only for true,false]
case = case!!1 if x = 0; !invert for false
pendcond = case&1+bra
-> endcomp
finish
if x >= explim start ; !address
dx == dict(x-ad); sx = 4
else
dx == dict(x)
tx == dict(dx_type); sx = size(dx_type)
finish
dx_flags = dx_flags!rflag
sy = tsize(y)
m = 4
if sx > 0 and sx < 4 start {< 32 bits}
if y <= 0 start
m = repsize(dx_type)
else if sy < 4
m = lcr(dx_type,dict(y)_type)
finish
unsigned if m < 0
finish
wx = 0 and wy = 0 and condswop if c_reg_ccx = y and c_reg_ccy = x
if c_reg_ccx # x or c_reg_ccy # y start
if y # 0 start ; !not comparison with zero
wx = weight(x); wy = weight(y)
condswop if wy > wx < 999
if x >= explim or y >= explim start ; !one or other is address
!swop if Y is not name (to use LEA)
condswop if 0 <= y-ad < dictlim and dict(y-ad)_flags >= 0
eval(x,anyareg)
eval(y,sign+anyareg)
plant(cmp,y,x)
c_reg_ccx = xx; c_reg_ccy = yy
else if sx > 0; !simple operand
if tx_flags&cat = realy start
eval(x,d0b); eval(y,d1b)
srcall(fsub)
forget(x)
c_reg_ccx = xx; c_reg_ccy = yy
else if y < 0; !comparison with literal
eval(x,sx<<sizeshift+val)
! Bring Y to reg if (a) MOVEQ-able, long, and reg available
! or (b) X mode is pcmode (no use for CMPI)
if (y >= litmite and sx = 4 and free&(anydreg-bregb) # 0) -
or (x > a7 and dx_mode&63 >= pcmode) start
eval(y,anydreg-bregb)
condswop and sx = sy unless 0 < x <= d7
else
sx = 2 if a0 <= x <= a7 and is short(litval(y))
finish
plant(cmp+sx<<8,y,x)
c_reg_ccx = xx; c_reg_ccy = yy
else ; !Y not literal
condswop if sy < sx
eval(x,anyreg+|m|<<sizeshift)
! %if sy <= 2 %and sy = sx %and (sy=1 %or x < a0) %start
eval(y,val+|m|<<sizeshift)
plant(cmp+|m|<<8,y,x)
! %else
! eval(y,val)
! plant(cmp,y,x)
c_reg_ccx = xx; c_reg_ccy = yy
! %finish
finish
else ; !structure
stsiz = sx; stsiz = -stsiz if tx_flags&cat # stringy
if case&8 = 0 or stringy # tx_flags&cat # sety start
!equals,notequals or rec,array
if wy >= 999 start ; !both complex
eval(x,tostack)
eval(y,anyareg!mod!asad)
x = freeareg(undef)
plant(move,a7,x)
else
eval(x,anyareg!mod!asad)
forget(x)
eval(y,anyareg!mod!asad)
finish
i = free dreg
if tx_flags&cat = stringy start ; !string comparison
plant(clr,0,i)
plant(moveb,x+indir,i)
else
plantlit(move,-sx-1,i)
finish
plant(cmpmb,x+post,y+post)
plantlit2(dbne,i,-4)
forget(i); forget(y)
else
if wy >= 999 start ; !both complex
eval(x,tostack); eval(y,a1b+asad)
x = a0
plant(move,a7,x)
else
eval(x,a0b+asad); eval(y,a1b+asad)
finish
!<
srcall(scomp)
unsigned
!<
finish
forget cc
finish
else ; !comparison with zero
if sx <= 0 {structure} -
or (sx = 1 and dx_mode >= dispmode) {byte, TSTable} start
if tx_flags&cat = stringy or sx = 1 start
eval(x,ref)
plant(tst+1<<8,0,x)
forget cc; !*for now*
unsigned
else
eval(x,anyareg!mod!asad)
i = free dreg
plantlit(move,-sx-1,i)
plant(tst+1<<8,0,x+post)
plantlit2(dbne,i,-4)
forget(i); forget(x)
finish
else if np0 <= x < explim and dx_act = and -
and case&8 = 0 and onebit(dx_y) # undef
! Testing one bit =0 or <>0
y = onebit(dx_y)
eval(y,anydreg) if y > 0
x = dx_x
sx = tsize(x)
if sx = 1 or y <= 0 then eval(x,sx<<sizeshift+dval) -
else eval(x,sx<<sizeshift+anydreg)
plant(btst+sx<<8,y,x) {NB size}
c_reg_ccx = xx; c_reg_ccy = 0
else
eval(x,anydreg)
if c_reg_ccx # xx or c_reg_ccy # 0 start
plant(move,x,x); c_reg_ccx = xx; c_reg_ccy = 0
finish
finish
finish
finish
pendcond = case
endcomp:
pendin = dp_x; pendout = dp_y
checksp:
if c_sp # sp start
addimm(sp-c_sp,a7); c_sp = sp
finish
!<
return
do(resolves):
flush if pendcond # 0
update sp
sp = c_sp
! push(mb)
! eval(x,a0b+asad); !string to be resolved
! act = dict(y)_act; x = dict(y)_x; y = dict(y)_y
! eval(x,a1b); eval(act,a0b<<2); eval(y,a0b<<3); !match, fore, aft
! srcall(resolves)
! pop(mb)
! forget regs
dx == dict(act)
call
pp = pp+2; dp == dict(pp)
pendcond = dp_act
-> endcomp
!<
!!!!!!!!!!!!!!!!!!!!!!!! Assignment !!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
predicate EASY(integer y)
! Determine if structure assignment can be done by store-to-store op(s)
! and if so, do it.
integer r1,f
record (identinfo)name dy
owninteger s=0
false if y < np0
dy == dict(y)
false if dy_act > concat or dy_act = prel
f = free
if dy_x = x start ; !recursion ends, successfully
s = tsize(x); s = -s if dy_act # concat; !+ve unless string
eval(x,a1b+asad)
else
false if dy_y >= np0 or dy_y = x c
or not easy(dy_x)
finish
y = dy_y
if y >= np0 and dict(y)_act = dtostring start
y = dict(y)_x; eval(y,to8+dval); !character value
r1 = clean reg
plant(addb,one,x+indir); !inc length(dest)
plant(moveb,x+indir,r1)
plant(moveb,y,tempx(x,r1)); !append char
forget(r1)
else
eval(y,a0b+asad)
structcall(dy_act,s)
forget(a0); forget(a1)
forget(d1); forget(d2)
finish
free = f&(\a1b)
true
end
routine BEWARE(integer dest)
![not foolproof: ?too expensive to do properly
! too inefficient to fail safe]
integer r,d
predicate UNSAFE(integer p)
![a bit cavalier]
cycle
true if p = dest or p = d {%or d >= np0
%false %if p <= undef; !literal, basereg or undef
p = p-ad %if p >= explim
%false %if p < np0
%true %if dict(p)_act > opmax; !funcall,mapcall
%true %unless dest # dict(p)_y < np0
p = dict(p)_x
%repeat
%end
d = dest; d = d-ad %if d >= explim
%for r = d0,1,maxareg %cycle
forget(r) %if r = dest %or unsafe(c_reg_content(r))
%repeat
forget cc %if unsafe(c_reg_ccx) %or unsafe(c_reg_ccy)
%end
%routine TOSTORE(%integer act,y)
! Global XX, X, SX, WX, DX
%if y <= 0 %start {literal}
eval(x,ref)
if y # 0 start {except for NEG,NOT}
if act&(\1) = add or (act&(\1) = lsl and x <= d7) start
if y >= litquick start ; !-8:-1 or 1:8
act = act+1 and y = y-1 if y&1 # 0; !negate if neg
-> past
finish
act = act+1 and y = y+1 if y = -(128<<1); !128=>-128
finish
eval(y,anydreg) if y >= litmite and sx&3 = 0 -
and free&(anydreg-bregb) # 0
finish
else if x <= a7 {reg}
eval(y,val)
else
if 999 > wx < weight(y) then eval(y,anydreg) and eval(x,ref) c
else eval(x,ref) and eval(y,anydreg)
finish
past:
plant(act+sx<<8,y,x)
plant(trapv,0,0) if control&overbit # 0 and act <= sub
beware(xx)
c_reg_ccx = xx; c_reg_ccy = 0
end
routine REGASSIGN(integer v)
! Global X, SX
integer f,b,vv
record (identinfo)name dp
predicate XFREE(integer y)
record (identinfo)name dp
cycle
y = y-ad if y >= explim
true if y <= 0
dp == dict(y)
exit if y < dictlim {simple operand}
false if not xfree(dp_y) and |dp_act| # recref
y = dp_x
repeat
false if dp_mode&63+d0 = x {same as LHS reg}
true
end
f = free; b = 1<<(x-d0)
vv = v; vv = vv-ad if vv >= explim
if vv >= dictlim start {complex}
dp == dict(vv)
if xfree(dp_y) or |dp_act| = recref start
free = free!b
else
free = free&(\b)
finish
if |dp_act| <= cmp or (|dp_act| <= divu and x < a0) start
dp_y = x and free = free!b if dp_y = dp_x
if free&b # 0 start
regassign(dp_x)
free = free&(\b)
tostore(dp_act,dp_y)
free = f
return
finish
finish
eval(v,val) if free&b = 0
else
return if vv > 0 and dict(vv)_mode&63+d0 = x
finish
free = free!b
eval(v,b)
free = f
end
!<
do(forass): !FORASS:loopvar:start'
! -- :inc :end
eval(y,d0b)
pp = pp+1; dp == dp[1]
i = dp_x; eval(i,d1b); i = dp_y; eval(i,d2b)
srcall(forok)
!<= explim %start; !ad of ...
wx = weight(xx-ad)
dx == dict(xx-ad)
sx = 4
%else
wx = weight(xx)
dx == dict(xx)
sx = size(dx_type)
%finish
tx == dict(dx_type)
sp = c_sp-c_val
%if sx <= 0 %start; !structure assignment
!Structure
![for rec/string assignment beware corruption of stacked
! structure in computing DEST]
update sp
%if tx_flags&cat = stringy %start
sx = -256 %if sx = 0; !string(*)
op = -1; op = dict(y)_act %if y >= np0
%if y = 0 %start; !""
eval(x,ref)
plant(clr+1<<8,0,x)
%else %if op = dtostring
y = dict(y)_x
eval(y,to8+dval); !character value
eval(x,anyareg!mod!asad)
plant(moveb,one,x+post)
plant(moveb,y,x+indir)
forget(x)
forget cc
%else %if act = jamass %or %not easy(y)
%if op >= concat %and wx > 1 %start
! Danger of corruption of RHS
stsiz = sx
eval(y,tostack)
free = free!a0b
eval(x,a1b+asad)
plant(move,a7,a0); y = a0
structcall(strcopy,1111<<<<<<<<============================>>>>>>>>>>>>>>???????@@@@@@AAAAABBCCDEG|ˆw蟘•›º¹®þî µ±¯¯ 8ëe±°²™ƒ³ïÙ•”“’’“”˜èËÑ“’’’“”`³²Ês–””•—ª}yy|`^]]\[[[ZZZZZZYYYYYYYXXXXXXXXXXWWWWWWWWWVVVVVVVVVVVVVVVVVUUUUUUUUUUUUUUUTTTTTTTTTTTTTSSSSSSSSSSSSSSSRRRRRRRRRRRRRRRRQQQQQQQQQQQQQQQQQQQQQPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPQQQQQQQQQQQRRRRRRSSSSTTUUW [øÉr|¹ñ“°— š±™Ë—ª¾ ‹¡á£Œlkll ëÁ»poor”Щ² §«©¶~Ÿ ¡£¤ëØ;ÒÅùüðüD8 X=x^Lð" ھΜ¸hpϸbƒgh€`¼Ó- . jg³644433333322222222222222211111111111111111111111111111111111111111mass %start
plantlit(move,mite(-sx-1),i)
plant(moveb,i,x+post)
plant(cmpb,y+post,i)
plantlit2(bcs,0,6); ! 3 2-byte instructions **
plant(sub,one,x)
plant(moveb,y+pre,i)
%else
plant(moveb,y+indir,i); !length (dirty OK) [2 bytes]
%finish
plant(moveb,y+post,x+post)
plant(subb,one,i)
plantlit2(bcc,0,-6)
forget(i)
! %finish
%else
%if wx > 1 %then eval(x,a1b+asad) %and eval(y,a0b+asad) %c
%else eval(y,a0b+asad) %and eval(x,a1b+asad)
structcall(strcopy,sx)
%finish
forget(x); forget(y)
forget cc
%finish
%else %if %not easy(y)
eval(x,anyareg&free+asad) %if y = 0 %or wx > 1
%if y # 0 %start
sx = tsize(y) %if sx = 0
eval(y,anyareg!mod!asad)
forget(y)
y = y+post
eval(x,anyareg!mod!asad) %if wx <= 1
%finish
forget(x)
%if sx = 0 %then fault(sizerr) %else move block(y,x+post,-sx)
%finish
beware(xx)
-> checksp
%finish
!Simple operand
%if c_val # 0 %start
%if dx_mode = c_mode -
%and (dx_val = sp %or (dx_val+sx = sp+c_val %and y <= 0)) %start
! current frame -- last or first in pending stack extension
c_val = (c_val-sx)&(\1)
update sp %if dx_val = sp
%finish %else update sp
%finish
op = move
%if sx # 4 %and act = assign %and control&capbit # 0 %start
eval(y,d0b)
srcall(dx_type); !range check
%finish
%if dx_mode&2_110000 = 0 %start; !explicit assignment to reg
x = dx_mode+d0
regassign(y)
c_reg_ccx = xx %and c_reg_ccy = 0 %if x <= d7
%else
case = val; case = case+sx<= explim
%if i >= np0 %start {RHS complex}
%if dx_flags&okflag # 0 %or control&bassbit>>1<= explim %start
! %if dy_act = prel %and dy_x = x-ad %c
! %and (dy_y < 0 %or dy_type = bytetype) %start
! y = dy_y
! y = litref(litval(y)*|size(dy_type)|) %if dy_type # bytetype
! tostore(add,y)
! -> endass
! %finish
! %else
%if dy_x = x %c
%and (0 <= dy_act < neg %or (dy_act = neg %and dy_y = 0)) %start
tostore(dy_act,dy_y)
-> endass
%finish
%finish
! %finish
%if wx < 999 %then eval(y,case) %and eval(x,ref) %c
%else eval(x,ref) %and eval(y,case)
%else {RHS simple}
eval(x,ref)
%if y <= 0 %start; !literal
%if y = 0 %and dx_flags&readable # 0 %start
op = clr
%else %if y >= litmite %and sx = 4 %and free&(anydreg-bregb) # 0
eval(y,anydreg)
%finish
%else
eval(y,case)
%finish
%finish
%if 0 < y <= maxareg %and 0 < yy = c_reg_content(y) %start
beware(xx)
c_reg_content(y) = xx {'part' as was}
%finish %else beware(xx)
plant(op+sx<<8,y,x)
c_reg_ccx = xx; c_reg_ccy = 0
%finish
endass:
dx_flags = dx_flags!okflag %if c_localdpos <= xx < dictlim %c
%and c_forward = 0
%return
do(incass): !(for %for loop)
flush %if pendcond # 0
dx == dict(xx)
sx = size(dx_type)
wx = weight(x)
tostore(add,y)
->endass
!!!!!!!!!!!!!!!!!!!!!! Returns and jumps !!!!!!!!!!!!!!!!!!!!!!!!
!
do(return): !terminate procedure
update sp
%if c_type # 0 %start; !function,map
r = dict(c_dpid_type)_reg&15
%if c_type > 0 %and size(c_type) > 0 %start; !simple fn
flush %if pendcond # 0 %and pendin # 0
i = y
![Tested here to avoid flush if no inst needed]
%if c_reg_content(r+d0) # y -
%or (r < a0 %and c_reg_part&1< 0; !ie struct fn
sp = c_sp
eval(y,1< 0 %and pendin # 0
save context(y) %if y # x; !exit not continue
compile uncond branch(y)
%return
do(repeat):
update sp
compile uncond branch(x)
define label(x+1) %if dict(x+1)_val < 0
%if y < 0 %start; !temp(s) declared
c_val = y; c_temps = c_temps+y; !decrement temps
update sp
%finish
%return
do(else):
%if c_access # 0 %and c_access # -2 %start
save context(y)
compile uncond branch(y); !outward branch for %else
%finish
define label(x) %if x # 0 %and dict(x)_val < 0; !inward from false cond
%return
do(goto): !user jump
update sp
c_forward = c_forward+1 %if dict(y)_val = 0
addimm(c_temps,a7) %if c_temps # 0
i = pendcond
compile uncond branch(y)
addimm(-c_temps,a7) %if i # 0 %and c_temps # 0
%return
do(label):
update sp
define label(x)
%return
do(stop):
update sp
flush %if pendcond # 0
plant(clr,0,d0)
srcall(signal)
c_access = 0
%return
do(signal):
update sp
flush %if pendcond # 0
sp = c_sp
pp = pp+1; dp == dp[1]
xx = dp_x; yy = dp_y
x = litval(x)
%if yy # undef %start
eval(yy,a0b+asad); x = x+64
%finish
%if xx # undef %start
eval(xx,d2b); x = x+32
%finish
%if y # undef %start
eval(y,d1b); x = x+16
%finish
x = litref(x)
eval(x,d0b)
%if control&sysbit # 0 %then plant(jmp,0,signal) %else plant(jsr,0,signal)
%if c_sp # sp %start; ![earlier?]
addimm(sp-c_sp,a7); c_sp = sp
%finish
c_access = 0
%return
do(settrap):
update sp
push(d0+6); ![historical]
push(mb)
plant(pea,0,temp(pcmode,10)); !address of mask [2+2+2+4]
c_sp = c_sp-4
push(gb+indir); ![2 bytes]
plant(move,a7,gb+indir); ![2 bytes]
c_eventsp = c_sp
c_forward = c_forward+1
lreg(c_lab1-dictlim) = c_reg; !regs for %finish
plant(bra,0,c_lab1); ![4 bytes]
pflag(pc-1) = longjump; !**not to be shortened
forget regs
plant(dc,0,temp(absmode,litval(y))); !event mask
! store(litval(y),0); !event mask
%return
do(swgoto): !switch jump
flush %if pendcond # 0
update sp
dx == dict(x)
dx_flags = dx_flags!rflag
dy == dict(dx_type)
get array info(dy,i,sx,sy)
i = dx_val; !start of table
%if y <= 0 %start; !literal subscript
y = litval(y)
i = i+y-sx
addimm(c_temps,a7) %if c_temps # 0
plant(bra,0,temp(labmode,prog(i)))
prog(i) = dtemp_val; !updated by PCREL
%else
eval(y,d0b)
%if i > pc %start; !first jump (I >= SWPC)
c_forward = c_forward+(sy-sx+1)
%if dx_flags&arrflag = 0 %start; !no check
addimm(c_temps,a7) %if c_temps # 0
plant(lea,temp(pcmode,10-sx-sx),a0); !LEA ?(PC),A0
plant(add,d0,d0); !ADD D0,D0
%else
wx = 12
%if c_temps # 0 %start
wx = wx+2; wx = wx+2 %if c_temps > 8
%finish
plant(lea,temp(pcmode,wx),a0)
srcall(index)
addimm(c_temps,a7) %if c_temps # 0
%finish
plant(add+2<<8,tempx(a0,d0),a0); !ADD.W 0(A0,D0),A0
plant(jmp,0,a0+indir); !JUMP (A0)
%if dx_flags&arrflag # 0 %start
store(sy>>16,0); store(sy,0)
store(sx>>16,0); store(sx,0)
store(0,0); store(2,0)
%finish
dx_val = pc
%cycle
store(prog(i),0)
swpc = swpc+1 %if i = swpc; i = i+1
sx = sx+1
%repeat %until sx > sy
%else; !just branch to earlier sequence
![gives wrong line number for error]
![wrong if temps]
i = i-7 %if dx_flags&arrflag # 0
plant(bra,0,temp(labmode,i-6))
%finish
%finish
c_access = 0
%return
do(asize):
%if y # 0 %start; !first: prime D0
update sp
eval(y,d0b); !basic itemsize
%else
srcall(asize)
%finish
pp = pp+1; dp == dp[1]
xx = dp_x; yy = dp_y
free = c_free&(\d0b); !not d0
eval(xx,d1b); !lower
eval(yy,d2b); !upper
push(d0); !size
push(d1); push(d2)
forget regs
free = free!(d1b+d2b)
dict(x)_val = c_sp
%return
!
do(adok): ![spare code]
!Push size of dynamic array (& 0-base value) for AGET
update sp
%if x # 0 %start
%if x # d0 %then eval(x,d0b) %else srcall(asize)
%finish
push(y) %if y # 0
push(d0)
%return
do(aget):
plant(move,x,d0)
srcall(aget)
plant(move,a7,x)
%if y # 0 %start
dx == dict(x)
dx_val = dx_val+4
plant(move,a7,d0)
plant(add,d0,x)
dx_val = dx_val-4
%finish
forget(d0); forget(a0)
%return
%routine COMPILE ENTRY(%integer linked,arg)
!Entry sequence generated at end
%integer i,r,vsp,lastvsp,holdsp
%record(identinfo)%name darg,tp
holdsp = c_sp
c_sp = 0; lastvsp = 0
c_stack = c_stack-4 %if linked > 0; !allow for link
%if linked = 0 %and c_status&onstack # 0 %start
!justify addressing assumed for onstack parameters
c_sp = 4; holdsp = holdsp-4; c_stack = c_stack-4
%finish
c_stack = c_stack-4; !and return address
c_totstack = c_stack %if c_stack < c_totstack
%if control&stackbit # 0 %c
%and (c_status&unknown # 0 %or c_totstack < -128) %start
plantlit(move,c_stack,breg); !*ok - gets cleared*
srcall(stackok)
%finish
%if level > 0 %and linked > 0 %start; !link required
%if level > 1 %start
plant(move,tempd(gb,level<<2),prea7); !MOVE ?(GB),-(SP)
plant(move,a7,tempd(gb,level<<2)); !MOVE SP,?(GB)
%else
plant(link,0,f1); !LINK #0,Ax
%finish
%finish
darg == dict(arg)
%cycle
arg = darg_link
%exit %if arg = 0
darg == dict(arg)
%if darg_val <= 0 %and darg_mode&2_110000 # 0 %start
! Passed in reg, not on stack, and not reg
vsp = darg_val
r = darg_reg&15+d0
%if darg_flags&mflag # 0 %or linked > 0 %start
addimm(lastvsp-c_sp,a7); c_sp = lastvsp
i = nsize(darg)
%if i > 0 %start
! name or simple operand by value
!NB MOVE.B transfers to hi byte
plant(move+i<<8,r,prea7)
%else %if darg_flags&proc # 0; !proc as param
plant(move,r,prea7)
plantlit(movew,16_4EF9,prea7); !JMP
%else; !structure by value
tp == dict(darg_type)
fault(plexerr) %if free&bregb = 0
%if tp_flags&cat = stringy %start
%if control&capbit # 0 %and tp_size > -256 %start
plantlit(cmp+1<<8,-tp_size,r+indir)
plantlit2(bcs,0,4)
srcall(check)
%finish
i = c_sp-vsp
addimm(-i,a7); !SP = SP-bytes
extend stack(i)
!MOVE.B length,Dx
plant(moveb,r+indir,breg)
!MOVE.B 0(Ay,Dx),0(SP,Dx)
plant(moveb,tempx(r,breg),tempx2(a7,breg))
plant(subb,one,breg)
plantlit2(bcc,0,-10)
%else; !fixed length structure
free = bregb
push block(r,c_sp-vsp)
%finish
%finish
c_sp = vsp
%finish
lastvsp = vsp
%finish
%repeat
%if c_sp # 0 %start; !there are accesses to params
addimm(lastvsp-c_sp,a7)
c_sp = holdsp
%finish %else c_sp = holdsp-lastvsp; !reduce
%end
do(end):
compile entry(c_status&globbed,c_dpid_type)
%return
do(*): intern(8)
do(0): !null action
%end; !eval
%routine COMPILE(%integer startp)
%integer p
{?} show exp(startp) %if control&explist # 0 %and control&list # 0
np = np0 %and %return %if faultnum > 0
pendcond = 0
p = startp-1
%cycle
free = c_free
p = p+1
%if p >= np %start
%if startp = np0 %start
np = np0
flush %if pendcond > 0
%return
%finish
np = startp; startp = np0; p = startp
%finish
%if c_reg_line # line %and control&(tracebit!linebit) # 0 %start
flush %if pendcond > 0
forget cc; pendcond = -1
%finish
eval(p,inst)
%repeat
%end; !compile
%routine SET FIRST ENTRY
%integer j,k,p
%record(identinfo)%name dp
firstpos = dictlim; firstentry = finalbound
p = 0
%cycle
p = p+1
%exit %if p >= dlim
dp == dict(p)
%continue %if dp_mode # procmode
%continue %if dp_val >= firstentry
j = dp_val
%if j <= 0 %start; !procedure not yet encountered
%continue %if j = 0
k = -j; !find earliest (first) call
%cycle
j = k<<1
k = code word(j)&16_FFFF
%repeat %until k = 0
%continue %if j >= firstentry
%finish
firstentry = j; firstpos = p
%repeat
%end
%routine DEFINE ENTRY(%integer chain,entry,pid)
%integer j
%cycle
chain = chain<<1
report(reacherr,pid,0) %unless is short(entry-chain)
j = code word(chain)&16_FFFF
!$IF VAX
{ final(chain) <- (entry-chain)>>8; final(chain+1) <- entry-chain
!$IF APM
shortinteger(final0+chain) <- entry-chain
!$FINISH
chain = j
%repeat %until chain = 0
%end
%routine CHECK REACH(%integer blocksize)
!Add stepping stones if necessary
%integer i
%cycle
i = blocksize+cad
croak("Program too big") %if i >= initbase
%return %if i-firstentry < 31000; !enough leeway
%return %if blocksize >= 32000 %or cad-firstentry >= 32760; !hopeless
%if dict(firstpos)_val < 0 %start
define entry(-dict(firstpos)_val,cad,firstpos)
set code word(16_6000); !BRA
dict(firstpos)_val = -cad>>1
set code word(0)
%else
dict(firstpos)_val = cad
set code word(16_6000); !BRA
set code word(firstentry-cad)
%finish
steps = steps+2
set first entry
%repeat
%end
%routine PUT WORD(%integer v)
printsymbol(v>>8&255); printsymbol(v&255)
%end
%routine DO EXTERNALS(%integer chain,specs)
%integer k,t,a,b
%record(identinfo)%name dp,tp
%integer%fn CHAR(%integer ad)
%result = byteinteger(ad) %if byteinteger(ad) < 'a' %or control&oldbit # 0
%result = byteinteger(ad)-32
%end
byteinteger(charlim) = 0; ![see test for %alias]
value = 2
%cycle
dp == dict(chain)
a = dp_text+char0; b = byteinteger(a)
%if byteinteger(a+b+1)&128 # 0 %start; !aliased
a = a+b+1; b = byteinteger(a)-128
%finish
value = value+(b+14)&(\1)
%if specs >= 0 %start; !for real
put word(dp_flags&(ext+proc)!sign16)
put word(dp_mode)
k = 0
%if dp_flags&proc # 0 %start
!create type word
tp == dict(dp_type)
k = 4; k = 6 %if tp_type # 0; !100:R 11x:F,M
%cycle
k = k+1 %if tp_reg&8 # 0; !0:dreg, 1:areg
%exit %if tp_link <= 0
tp == dict(tp_link); k = k<<1
%repeat
k = k+2 %if k = 9 %and tp_type = stringtype %and tp_flags >= 0
%finish
put word(k>>16); put word(k)
put word(dp_val>>16); put word(dp_val)
put word(b<<8+char(a+1))
%cycle
a = a+2; b = b-2
%exit %if b < 0
k = char(a)<<8
k = k+char(a+1) %if b > 0
put word(k)
%repeat
%finish
chain = dp_link
%repeat %until chain = 0
%if specs >= 0 %start
put word(0)
put word(0) %if value&3 # 0
%finish
value = (value+3)&(\3)
%end
!
%routine PUTACT(%integer act,x,y)
dict(np)_act = act; dict(np)_x = x; dict(np)_y = y
np = np+1
%end
%routine COMPILE END
%integer i,j,x,y,entry,lim
%if c_reg_line # line %and control&(linebit+tracebit) # 0 -
%and level > 0 %and c_access # 0 %start
pendcond = -1
flush
%finish
!Pop event block
%if c_eventsp # 0 %start
plant(move,temp(c_mode,c_eventsp),gb+indir)
forget cc
%finish
!Put pre-amble
codeflag = '^'; x = pc; !preserve
putact(end,0,0)
compile(np0)
fill code(1) %if cad&1 # 0
check reach((pc-c_localpc)<<1)
entry = cad
y = x
%while y < pc %cycle
%if pflag(y) = indglobal %then set code word(dict(prog(y))_val-cad) %c
%else set code word(prog(y))
y = y+1
%repeat
codeflag = ' '; pc = x; !restore
!Generate final sequence
%if c_access # 0 %start
%if level > 0 %and c_status&globbed # 0 %start
%if level > 1 %start; !display in store
plant(move,tempd(gb,level<<2),a7); !MOVE ?(GB),SP
plant(move,posta7,tempd(gb,level<<2)); !MOVE (SP)+,?(GB)
forget cc
%else
plant(unlk,0,f1)
%finish
%else %if c_sp < 0; !some stack extension
addimm(-c_sp,a7)
%finish
%if level > 0 %start
%if c_type # 0 %start
c_dpid_flags = c_dpid_flags!okflag %if c_status&okcc # 0 -
%and c_reg_ccx!c_reg_ccy = 0 {not undeffed}
%finish
plant(rts,0,0)
%else
plant(move,0,d0); srcall(signal); !%stop
%finish
%else; !no return from procedure
c_dpid_flags = c_dpid_flags!noret
%finish
!Set start address
x = c_dpid_val
define entry(-x,entry,c_pid) %if x < 0; !forward refs in FINAL
c_dpid_val = entry
!
lim = cad+(pc-c_localpc-c_shorts+zeroshorts)<<1
x = c_localpc; c_shorts = zeroshorts; !reset
%while x < pc %cycle
y = prog(x); j = pflag(x)
%if j # 0 %start
%if j < zeroshorts %start
%if j <= longjump %start; !shortjump/jump/longjump
jumps = jumps+1
y = (y-pflag(y)-x+c_shorts)<<1
%if j = shortjump %start
cad = cad-2
y = prog(x-1)+y&255
c_shorts = c_shorts+1
%finish
%else %if j = indglobal; !procedure
i = dict(y)_val
%if i <= 0 %start; !not yet encountered
dict(y)_val = -(cad>>1); y = -i
%else
i = i-cad
report(reacherr,y,0) %unless is short(i)
y = i
%finish
%else {global,negglobal,bigglobal}
%if j # global+1 %start
y = y&16_FFFF
y = y+65536 %if j # global; !bigglobal
%finish
y = y-cad
%unless is short(y) %start
%if prog(x-1)&16_F1FF # 16_41FA %start; !LEA (PC),Ax
report(creacherr,0,cad)
%else
i = cad; cad = lim
set code word(prog(x-1)!!(16_41FA!!16_207C)); !MOVEI #,Ax
set code longword(y-2)
set code word(prog(x-1)!!(16_41FA!!16_D1D7)); !ADD (SP),Ax
set code word(16_4E75); !RTS
lim = cad; cad = i-2
set code word(16_6100); !BSR
y = lim-10-cad
steps = steps+5
%finish
%finish
%finish
%finish
%finish
!$IF VAX
{ final(cad) <- y>>8; final(cad+1) <- y
!$IF APM
shortinteger(final0+cad) <- y
!$FINISH
cad = cad+2
x = x+1
%repeat
cad = lim
forget all
%end; !compile end
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!! end of Code Generation !!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!<t want to let LIT/EXP
! get out of hand so RESET CONTEXT forgets triples
croak("Too many levels") if level = maxlevel
c_oldcontrol = control
hold(level) = c; level = level+1; vintage = vintage+1
reset context(pid,c_free)
c_access = 1; c_localad = cad-accounted
end ; !OPEN BLOCK
predicate PARMATCH(integer apos,bpos)
record (identinfo)name ap,bp,atp,btp
cycle
ap == dict(apos); bp == dict(bpos)
false if ap_flags!!bp_flags < 0
{%false %if ap_mode # bp_mode}
if ap_type # bp_type start
![for now -- nominal]
atp == dict(ap_type); btp == dict(bp_type)
false unless atp_flags&cat = arry = btp_flags&cat
finish
apos = ap_link; bpos = bp_link
if apos = 0 start
false if bpos # 0
true
else if bpos = 0
false
finish
repeat
end
integer fn CRUNCHED(integer p)
record (identinfo)name dq,dp==dict(p)
owninteger q=0,l=0
dp_text = 0; q = 0
l = dp_link
if l # 0 start
l = crunched(l) if dp_type < p
result = p if p <= l
dp_link = l
q = l-1
finish
dq == dict(q)
while q < p cycle
if dq_type = dp_type c
and dq_link = l and dq_reg = dp_reg and dq_val = dp_val start
dlim = p
result = q
finish
q = q+1; dq == dq[1]
repeat
result = p
end
routine FIXUP SWITCH VECTOR(integer pos,record (identinfo)name dp)
integer x,y,j,default,temp,lo,hi
record (identinfo)name tp==dict(dp_type)
x = dp_val
default = dp_link; default = pc if default = 0
get array info(tp,j,lo,hi)
if dp_flags&arrflag = 0 then j = pflag(x-1)+lo c
else j = pflag(x-7); !allow for dope info
j = x-j; !base position
while lo <= hi cycle ; !For each element
y = prog(x)
if y <= 0 start ; !not set
if dp_link = 0 start ; !no default
report(slabmissing+warn,pos,lo)
c_access = 1
finish
if y < 0 start ; !explicit jump(s) to this one
y = -y
cycle ; !define jumps to default
temp = y; y = prog(temp); prog(temp) = default
repeat until y = 0
finish
y = default
finish
prog(x) = (y-pflag(y)-j)<<1
x = x+1; lo = lo+1
repeat
end
routine CHECK USAGE(integer base)
integer miss=0,under=0,pos,idmiss=idmissing+warn
record (identinfo)name dp
pos = dlim; dp == dict(pos)
while pos > base cycle
pos = pos-1; dp == dp[-1]
if dp_flags&ext = 0 start
!<
!<
if dp_text > 0 start ; !user id
set hashhead(string(dp_text+char0))
if head = pos start ; !still active
head = dp_hlink; !remove from hash list
check: if dp_flags&spec # 0 start
dp_hlink = miss; miss = pos
idmiss = idmissing if dp_val # 0 {hard error if used}
else if ((dp_flags&(readable+rflag) = readable and dp_mode # litmode) c
or (dp_flags&(writable+okflag+wflag+spec) = writable)) c
and pos >= c_localdpos and dp_mode # 0 and dp_flags&typeid = 0 c
and control&(list!maplist) # 0
dp_hlink = under; under = pos
finish
finish
finish
else if level = 0; !external, external spec
if dp_flags&spec = 0 start ; !external object
dp_link = externs; externs = pos
finish else if dp_flags&(rflag+wflag) # 0 start
!external spec (used)
dp_link = extspecs; extspecs = pos
finish
finish
repeat
report(idmiss,miss,0) if miss # 0
if under # 0 and c_faults = 0 start
put ident(under,1)
put string(" underused")
print line
finish
return if base = 0
dlim = c_parlim
! %for i = 0,1,255 %cycle
! hashindex(i) = dict(hashindex(i))_hlink %while hashindex(i) >= c_localdpos
! %repeat
charlim = c_localtext
ranges = dict(ranges)_hlink while ranges >= c_parlim
set first entry if firstpos >= dlim
dictshown = dlim if dictshown > dlim
starts = 0; cycles = 0
end
routine CLOSE BLOCK
integer pos; record (identinfo)name dp
! For a function etc, C_STATUS&OKCC is set if all results
! have correct CC. CCX and CCY are set to special values
! so that if the exit sequence changes, OKFLAG will not be
! set.
c_reg_ccx = 0 and c_reg_ccy = 0 if c_status&okcc # 0
if c_return # 0 start
if c_return = -(pc-1) and c_access = 0 start
c_return = -prog(pc-1); pc = pc-2
finish
define jumps(c_return); !must precede switch fixup
c_access = -1
finish
pflag(pc) = c_shorts; !in case of terminal switch labels
if c_status&hadswitch # 0 start
pos = c_localdpos
while pos < dlim cycle
dp == dict(pos)
fixup switch vector(pos,dp) if dp_mode = labmode and dp_type # 0
pos = pos+1
repeat
finish
compile end
c_totstack = c_totstack-c_extra
c_totstack = -c_totstack if c_status&unknown = 0; !positive if firm
dict(c_dpid_type)_val = c_totstack
{?} if control&maplist # 0 start
{?} put ident(c_pid,-1)
{?} mark at(20)
{?} put string(" code:")
{?} put num(cad-c_localad-accounted)
{?} put string(" entry:")
{?} put num(c_dpid_val-c_localad-accounted)
{?} put string(" stack:"); put num(-c_stack)
{?} putsym('/'); put num(|c_totstack|)
{?} put sym('+') if c_totstack < 0
{?} accounted = cad-c_localad
{?} print line
{?} finish
pc = c_localpc; swpc = c_localswpc; curlab = c_lab1
if level = 0 then check usage(0) else start
check usage(c_localdpos)
c_dpid_type = crunched(c_dpid_type)
level = level-1; c = hold(level)
control = control&editbit ! c_oldcontrol&(\editbit)
finish
end ; !CLOSE BLOCK
routine ERROR(integer case)
faultp = atomp
report(case,0,0)
signal fail
end
constinteger DUD=63
routine SYNTAX ERROR
if atom = dud then error(atomerr+point) else error(formerr+point)
end
routine EXPFAULT(integer case)
if faultnum = 0 or expp < faultp start
faultnum = case!point; faultp = expp
finish
end
routine NONSTANDARD(integer case)
integer b
owninteger hadit=0
b = 1<<case
if b&hadit = 0 and control&nonsbit = 0 and faultnum = 0 start
hadit = hadit+b; faultp = atomp
if control&strictbit # 0 then report(nonstand+point,0,case) c
else report(nonstand+point+warn,0,case)
finish
end
routine NAME ERROR
!check if the culprit has occurred before
!and, if not, add it to the pool of unknowns stored at the
!far end of the dictionary.
if item >= 0 start ; !first time
fault(namerr+point+now)
if charmin-newlen-80 >= charlim start
dmin = dmin-1; dmin0 = dmin
charmin = charmin-newlen-1
string(charmin) = string(charlim)
dict(dmin)_text = charmin-char0
head == dict(head)_hlink while head > 0; !find last link
dict(dmin)_hlink = head; head = -dmin
finish
finish else others = others+1
signal fail
end
routine FIND OP(integer mnemonic,integername op,types)
integer i
i = 0
cycle
i = i+2
error(namerr) if i > defmax+defmax
repeat until def(i) = mnemonic
types = def(i-1); op = i>>1
end
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!! Source input !!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
routine READ LINE(integer flag)
! Read (or otherwise make available) the next source line
! Output any pending error report; *NB*
! Skip remnant of previous line if SYM # NL *NB*
! Set LINESTART to point to start of new line
! Print new line on list output stream if listing requested
! (Direct output routines CF diagnostics)
report(faultnum,0,0) if faultnum # 0
while sym > nl cycle ; !Skip remnant
sym = byteintegeR(fp); fp = fp+1
repeat
line = line+1
while fp = curlim cycle
if curlim # cur_lim2 start ; !in part1 of file
fp = cur_start2
else if curfile = main; !on main
signal done
else
cur_flag = -1
disconnect edfile(cur)
curfile = curfile-1
cur == file(curfile)
fp = cur_fp; line = cur_line
control = fcontrol(curfile)
inclim = dlim if level = 0 and c_status < hadon
finish
curstart = cur_start2; curlim = cur_lim2
if fp < curstart or fp > curlim start
curstart = cur_start1; curlim = cur_lim1
finish
repeat
linestart = fp
if flag = 0 start
flag = ' '; flag = '&' if curfile # main
finish
listflag = flag
if control&list # 0 start
time1 = time1-cputime
print line if rep # ""
show dict(dictshown) if control&dictlist # 0
dictshown = dlim
write(line,4); print symbol(listflag)
print symbol(' ')
cycle
sym = byteintegeR(fp); fp = fp+1
print symbol(sym)
repeat until sym <= nl
fp = linestart
time1 = time1+cputime
finish
sym = 0
end ; !READ LINE
!<
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!! Lexical processing !!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
constinteger CASEBIT=32
owninteger PERCENT=0, SUBATOM=0
!
!~!!!!!!! Keyword codes -- used by KEYGEN to produce tables !!
constinteger KEYEND=1 {end},
KEYREPEAT=2 {repeat},
KEYFINISH=3 {finish},
KEYELSE=4 {else},
KEYBEGIN=5 {begin},
EXIT=6 {exit_1,continue_0},
KEYRETURN=7 {return},
TF=8 {true_1,false_0},
KEYRESULT=9 {result},
KEYSTOP=10 {stop},
KEYGOTO=11 {goto},
KEYSIGNAL=12 {signal},
KEYMONITOR=13 {monitor},
KEYON=14 {on},
IU=15 {if_0,unless_1},
KEYWHILE=16 {while},
KEYUNTIL=17 {until_1},
KEYFOR=18 {for},
KEYTHEN=19 {then},
KEYSTART=20 {start},
KEYCYCLE=21 {cycle},
KEYLABEL=22 {label},
KEYCONST=23 {const,constant},
KEYOWN=24 {own},
KEYEXT=25 {external_6,system_5,dynamic_7},
KATTRIB=26 {readonly_0,writeonly_1,volatile_2,register_3},
KTYPE=27 {short_3,half_6,byte_9,mite_12,boolean_15,char_18,text_25},
KEYINTEGER=28 {integer},
KEYLONG=29 {long},
KEYREAL=30 {real},
KEYSTRING=31 {string_0,cstring_1},
KEYRECORD=32 {record},
KEYNAME=33 {name},
KEYFORMAT=34 {format},
FNMAP=35 {fn_0,function_0,map_1},
RPRED=36 {routine_0,predicate_1},
KEYSPEC=37 {spec},
KEYARRAY=38 {array},
KEYSWITCH=39 {switch},
KEYOF=40 {of},
KEYFILE=41 {file},
KEYPROGRAM=42 {program},
KEYLIST=43 {list},
KEYCONTROL=44 {control},
KEYCOMMENT=45 {comment},
KEYEVENT=46 {event},
KEYINCLUDE=47 {include},
KEYOPTION=48 {option},
KEYALIAS=49 {alias},
KEYNOT=50 {not},
KEYAND=72 {and},
KEYOR=73 {or}
!! end of keyword codes
!
!Symbol lexical codes other than operators:
constinteger TERMINATOR=51, CONST=52, IDENT=53, MODSIGN=54,
COLON=59, COMMA=60, RIGHT=61, RIGHTB=62, DOLLAR=64,
QUERY=65
{DUD=63}
constinteger LEFT=55, LEFTB=56, ATSIGN=57, UNDERLINE=58
constinteger ARROW=74, EQEQ=75, NOTEQEQ=76,
EQUALS=77, NOTEQ=78, LESSEQ=79,
LESS=80, GREATEQ=81, GREATER=82
constinteger PLUS=83, MINUS=84, EXCLAM=85, EXCLAM2=86, DOT=87
constinteger STAR=88, SLASH2=89, SLASH=90, AMPERSAND=91
constinteger STAR2=92, BACKSLASH=93, UPARROW=94,
BACKSLASH2=95, UPARROW2=96,
TILDE=97,
LSHIFT=98, RSHIFT=99
constinteger ATOMMAX=99
constinteger ALEFT=left, ARIGHT=right, RECSUB=underline,
OVER=slash2, SCONC=dot, HASHSIGN=noteq
constinteger SIMPLE=atommax+1, VSIMPLE=simple+1,
MAJOR=plus, SCOND=arrow, COND=keyand, CONDQ=71
!
integer fn NEXT ATOM
!Encode next atom from source file
![Time-critical]
switch s(0:255)
constinteger TAB=9,
MAX10=maxint//10, MAXDIG=maxint-max10*10
integer i,j,p,radix,hash
real rval
constbytearray map(0:127) =
0 ('0'),
'0','1','2','3','4','5','6','7','8','9',
0, 0, 0, 0, 0, 0, 0,
'a','b','c','d','e','f','g','h','i','j','k','l','m',
'n','o','p','q','r','s','t','u','v','w','x','y','z',
0, 0, 0, 0, 0, 0,
'a','b','c','d','e','f','g','h','i','j','k','l','m',
'n','o','p','q','r','s','t','u','v','w','x','y','z',
0, 0, 0, 0, 0
!~!!!!!!!!!!!!!!! Ex KEYGEN !!!!!!!!!!!!!!!!!!!!
CONSTSHORTINTEGERARRAY SYMINIT(97:122) = C
2,15,31,72,79,102,133,137,141,1,1,156,169,183,190,205,
1,220,264,304,316,326,334,1,1,1
CONSTBYTEINTEGERARRAY SYMBOL(1:347) = C
128,114,114,97,121,166,108,105,97,115,177,110,100,200,101,103,
105,110,133,121,116,101,155,111,111,108,101,97,110,155,111,110,
116,105,110,117,101,134,121,99,108,101,149,104,97,114,155,115,
116,114,105,110,103,159,109,109,101,110,116,173,115,116,97,110,
116,151,151,114,111,108,172,121,110,97,109,105,99,153,110,100,
129,108,115,101,132,120,105,116,134,118,101,110,116,174,116,101,
114,110,97,108,153,105,110,105,115,104,131,97,108,115,101,136,
111,114,109,97,116,162,110,163,117,110,99,116,105,111,110,163,
146,108,101,169,111,116,111,139,97,108,102,155,102,143,110,116,
101,103,101,114,156,99,108,117,100,101,175,97,98,101,108,150,
111,110,103,157,105,115,116,171,111,110,105,116,111,114,141,105,
116,101,155,97,112,163,97,109,101,161,111,116,178,110,142,119,
110,152,102,168,112,116,105,111,110,176,114,201,114,101,100,105,
99,97,116,101,164,111,103,114,97,109,170,101,112,101,97,116,
130,111,117,116,105,110,101,164,116,117,114,110,135,115,117,108,
116,137,97,100,111,110,108,121,154,103,105,115,116,101,114,154,
99,111,114,100,160,108,158,116,111,112,138,105,103,110,97,108,
140,121,115,116,101,109,153,104,111,114,116,155,112,101,99,165,
119,105,116,99,104,167,97,114,116,148,114,105,110,103,159,114,
117,101,136,104,101,110,147,101,120,116,155,110,108,101,115,115,
143,116,105,108,145,111,108,97,116,105,108,101,154,104,105,108,
101,144,114,105,116,101,111,110,108,121,154
CONSTBYTEINTEGERARRAY ALTDISP(1:347) = C
0,5,0,0,0,0,5,0,0,0,0,0,0,0,5,0,
0,0,0,4,0,0,9,0,0,0,0,0,0,15,8,23,
28,34,0,0,0,0,5,0,0,0,0,4,0,0,18,0,
0,0,0,0,0,1,0,0,0,0,0,0,0,0,4,0,
0,0,0,0,0,0,0,0,0,0,0,0,0,7,3,0,
0,4,0,0,0,4,8,0,1,0,0,0,0,0,0,0,
0,0,0,0,6,6,27,0,0,0,0,5,0,0,0,0,
6,0,14,0,0,0,2,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,0,6,2,0,0,6,
0,0,0,0,0,0,0,0,0,0,0,5,0,0,0,0,
4,0,0,0,0,0,0,0,7,0,0,0,0,0,0,4,
0,0,12,0,0,1,4,0,0,0,0,0,0,2,0,3,
0,0,2,0,6,0,0,0,0,0,0,0,0,8,0,0,
0,0,0,0,1,0,0,0,0,0,0,6,12,0,0,0,
0,0,0,0,0,0,0,0,5,0,0,0,0,5,0,0,
0,0,7,18,0,0,0,0,0,7,0,0,0,0,0,3,
0,0,0,0,0,0,0,4,30,0,0,6,0,0,0,0,
0,6,0,0,0,0,5,5,0,0,0,3,4,0,0,0,
0,0,0,0,0,0,4,0,0,0,0,0,0,0,0,4,
0,0,1,4,0,0,0,0,0,0,25,0,5,0,0,0,
1,0,0,0,1,0,0,0,0,0,0,0,2,5,0,0,
0,0,0,0,0,0,0,0,0,0,1
!! end of generated tables
routine GET SYM
cycle
sym = byteintegeR(fp); fp = fp+1
repeat until sym # ' '
i = sym-'0'
if i >= 10 start
i = sym!casebit-'a'; i = i+10 if i >= 0
finish
end
matched = 0
again: s(tab):
read line(0) if sym = nl
again1:
cycle
sym = byteintegeR(fp); fp = fp+1
repeat until sym # ' '
atomp = fp; !(actually one after)
atoms = atoms+1
-> s(sym)
linebreak: s(nl):
result = terminator if atom # comma
continuation:
read line('+')
-> again1
s('{'):
comments = comments+1
cycle
sym = byteintegeR(fp); fp = fp+1
-> linebreak if sym = nl
repeat until sym = '}'
-> again
s('+'): result = plus
s('-'): fp = fp+1 and result = arrow if byteintegeR(fp) = '>'
-> continuation if byteintegeR(fp) = nl
result = minus
s('*'): result = star
s('/'): fp = fp+1 and result = slash2 if byteintegeR(fp) = '/'
result = slash
s('\'): fp = fp+1 and result = backslash2 if byteintegeR(fp) = '\'
fp = fp+1 and result = noteq if byteinteger(fp) = '='
result = backslash
s('^'): fp = fp+1 and result = uparrow2 if byteintegeR(fp) = '^'
result = uparrow
s('~'): result = tilde
s('!'): fp = fp+1 and result = exclam2 if byteintegeR(fp) = '!'
result = exclam
s('&'): result = ampersand
s('.'): rval = 0 and -> fraction if '0' <= byteinteger(fp) <= '9'
result = dot
s('='): fp = fp+1 and result = eqeq if byteintegeR(fp) = '='
result = equals
s('#'): fp = fp+1 and result = noteqeq if byteintegeR(fp) = '#'
result = noteq
s('<'): fp = fp+1 and result = lesseq if byteintegeR(fp) = '='
fp = fp+1 and result = noteq if byteintegeR(fp) = '>'
fp = fp+1 and result = lshift if byteintegeR(fp) = '<'
result = less
s('>'): fp = fp+1 and result = greateq if byteintegeR(fp) = '='
fp = fp+1 and result = rshift if byteintegeR(fp) = '>'
result = greater
s('_'): result = underline
s(':'): result = colon
s(','): result = comma
s(';'): result = terminator
s('('): result = left
s('['): result = leftb
s(')'): result = right
s(']'): result = rightb
s('|'): result = modsign
s('@'): result = atsign
s('$'): result = dollar
s('?'): result = query
s('M'): s('m'):
fp = fp+1 and -> charconst if byteintegeR(fp) = ''''
s('A'):s('B'):s('C'):s('D'):s('E'):s('F'):s('G'):s('H'):
s('I'):s('J'):s('K'):s('L'):s('N'):s('O'):s('P'):
s('Q'):s('R'):s('S'):s('T'):s('U'):s('V'):s('W'):s('X'):
s('Y'):s('Z'):s('a'):s('b'):s('c'):s('d'):s('e'):s('f'):
s('g'):s('h'):s('i'):s('j'):s('k'):s('l'):s('n'):
s('o'):s('p'):s('q'):s('r'):s('s'):s('t'):s('u'):s('v'):
s('w'):s('x'):s('y'):s('z'):
-> keyword if percent # 0
newlen = charlim+1; hash = sym!casebit; !lower-case (if letter)
byteinteger(newlen) = hash
cycle
sym = byteintegeR(fp); fp = fp+1
repeat until sym # ' '
if sym = '''' start ; !damned IBM-style literals
radix = 16 and ->ibm if hash = 'x'
radix = 8 and ->ibm if hash = 'k'
radix = 2 and ->ibm if hash = 'b'
finish
sym = map(sym)
if sym # 0 start
cycle
newlen = newlen+1; byteinteger(newlen) = sym
hash = hash<<1!!sym
cycle
sym = byteintegeR(fp); fp = fp+1
repeat until sym # ' '
sym = map(sym)
repeat until sym = 0
finish
fp = fp-1
newlen = newlen-charlim; byteinteger(charlim) = newlen
if subbed # 0 then head == dformat_link c
else head == hashindex(hash&255)
item = head
if item # 0 start
cycle
ditem == dict(|item|)
exit if string(ditem_text+char0) = string(charlim) c
and (item > a7 or item < 0 or control&lowbit # 0)
item = ditem_hlink
repeat until item = 0
finish
identatoms = identatoms+1
result = ident
s('%'):
sym = byteintegeR(fp)
-> again unless 'a' <= sym!casebit <= 'z'
fp = fp+1
keyword:
percent = 0
p = syminit(sym!casebit)
cycle
! %cycle
! sym = byteintegeR(fp)!casebit
! %exit %if symbol(p) # sym
while symbol(p) = byteintegeR(fp)!casebit cycle
p = p+1; fp = fp+1
repeat
exit if symbol(p) > 127
atom = altdisp(p)
if atom = 0 start
result = dud unless sym!casebit = 'c' and byteintegeR(fp) = nl
->continuation
finish
p = p+atom
repeat
percent = 1 if 'a' <= byteintegeR(fp)!casebit <= 'z'
subatom = altdisp(p)
atom = symbol(p)-128
result = dud if atom = 0
result = atom
ibm:
nonstandard(20)
item = -1; value = 0
-> ibm1
s('0'):s('1'):s('2'):s('3'):s('4'):s('5'):s('6'):s('7'):s('8'):s('9'):
item = 0; type = inttype
radix = 10; value = sym-'0'
ibm1:
cycle
cycle
cycle
sym = byteintegeR(fp); fp = fp+1
repeat until sym # ' '
i = sym-'0'
if radix = 10 start
exit if i < 0 or i >= 10
fault(rangerr+point+warn) if value > max10 or (value=max10 and i > maxdig)
value = (value<<2+value)<<1+i
else
i = sym!casebit-'a'+10 if i >= 10
exit if i < 0 or i >= radix
j = radix
cycle
i = i+value if j&1 # 0
value = value<<1; j = j>>1
repeat until j = 0
value = i
finish
repeat
exit unless sym = '_'
radix = value
result = dud if radix = 0
value = 0
repeat
if item < 0 start ; !IBM-style
result = dud if sym # ''''
item = 0
else
j = 0
if sym = '.' start
rval = value if type = inttype
fraction:
j = 0
type = realtype
cycle
get sym
exit unless 0 <= i < radix
rval = rval*radix+i; j = j-1
repeat
result = dud if j = 0
finish
if sym = '@' start
type = realtype and rval = value if type = inttype
get sym
value = 0
if sym = '+' then get sym c
else if sym = '-' then value = 1 and get sym
result = dud unless 0 <= i < radix
p = 0
cycle
p = p*radix+i
get sym
repeat until not 0 <= i < radix
p = -p if value # 0
j = j+p
finish
if type = realtype start
rval = rval*radix^j if j # 0
value = integer(addr(rval)) if type = realtype
finish
fp = fp-1; sym = 0
finish
litatoms = litatoms+1
result = const
s(''''):
charconst:
item = 0; type = inttype
value = 0
cycle
sym = byteintegeR(fp); fp = fp+1
result = dud if sym = nl; !?allow
if sym = '''' start
exit unless byteintegeR(fp) = ''''
fp = fp+1
finish
value = value<<8+sym
repeat
result = const if value # 0
result = dud
s('"'):
item = 0
value = cad; type = stringtype
i = line; j = linestart; p = 0
cycle
sym = byteintegeR(fp); fp = fp+1
if sym = '"' start
exit if byteintegeR(fp) # '"'
fp = fp+1
finish
p = p+1
if p > 255 start
sym = 0
fp = atomp; linestart = j
result = dud
finish
final(value+p) = sym
read line('"') if sym = nl
repeat
if p # 0 start ; !not empty string
final(value) = p
cad = cad+(p+1)
finish else value = 0
litatoms = litatoms+1
result = const
s(*):
result = dud
end ; !NEXT ATOM
!<
{%volatile}predicate A(integer k)
!Basic atom-testing predicate
atom = next atom if matched # 0
false if k # atom
matched = 1
true
end
routine GET(integer k)
atom = next atom if matched # 0
matched = 1
return if atom = k
syntax error { %if atom = dud
! faultp = atomp
! report(formerr+point,-k,0)
! %signal fail
%end
!< 0 %and f&ext = 0; !already exists
charlim = charlim+newlen+1
croak("Identifier space exhausted") %if charlim+80 >= charmin
k = charlim-newlen-1-char0
%if f&ext # 0 %and a(keyalias) %start
get LITSTRING
string(charlim) = string(final0+value)
byteinteger(charlim) = byteinteger(charlim)+128
charlim = charlim+byteinteger(charlim)-127
%finish
%result = k
%end
%routine DECLARE(%record(objinfo)%name d)
%integer i
%record(identinfo)%name dp
dp == dict(dlim)
%if speccing = 0 %start; !not within spec params
%if item >= c_localdpos %start; !there already
%if d_flags&spec = 0 %and ditem_flags&spec # 0 %start
!body after spec (proc,label,typeid)
%if d_flags&(ext+proc+typeid) = ditem_flags&(ext+proc+typeid) %start
i = item
%if d_flags&ext # 0 %start
![can't allow %ext%spec, then use, then %ext object]
->ok %if ditem_flags&rflag # 0; ![so create new entry]
ditem_mode = d_mode; ditem_val = d_val
%if a(keyalias) %start
get LITSTRING; !ignore [should be identical]
item = i
%finish
%finish
%if d_flags&proc = 0 %start
ditem_flags = ditem_flags&(\(spec+indirect))
%finish
%return
%finish
%if ditem_flags&(ext+proc) = proc1 %and d_flags&ext # 0 %c
%and d_flags&proc # 0 %start; !(internal) %spec then %ext
ditem_flags = ditem_flags-proc1+(d_flags&(ext+proc))
ditem_text = idtext(ext); !in case alias
%return
%finish
%finish
!<= dmin %start
{?} show dict(0) if control&logbit # 0
croak("Too many identifiers")
finish
end ; !DECLARE
routine DECLARE ANON(record (objinfo)name d)
speccing = speccing+1
item = 0
declare(d)
speccing = speccing-1
end
!
record (objinfo)map DETAILS(integer f,t,m,v)
ownrecord (objinfo) D=0
d_flags = f; d_type = t
d_mode = m; d_val = v
result == d
end
routine DECLARE TEMP(integer t)
c_val = c_val+4; c_temps = c_temps+4
declare anon(details(okflag+writable+readable,t,c_mode,c_sp-c_val))
end
!
routine DECLARE RANGE(integer type,lower,upper)
!Type ident just declared
integer s
integer fn OK(integer l,u,s)
result = s if l <= lower and upper <= u
result = -s if 0 <= lower and upper <= u-l
result = 0
end
s = ok(-128,127,1)
s = ok(-32768,32767,2) if s = 0
s = 4 if s = 0
ditem_details = details(typeid,type,absmode,sign)
ditem_size = s
declare anon(details(okflag,type,litmode,lower))
declare anon(details(okflag,type,litmode,upper))
ditem_hlink = ranges; ranges = item
item = item-2
end
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!! Expressions !!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
owninteger LITERAL=0, JAMMY=0
routine spec GET EXPRESSION(integer rank,etype)
!
predicate VALOK(integer wanted,t)
integer lo,hi,l,h,wc,tc
record (identinfo)name wp,tp
true if wanted = t # recstar
wp == dict(wanted); tp == dict(t)
wc = wp_flags&(packed+cat); tc = tp_flags&(packed+cat)
if wc = tc start ; !same class
if wc&nonord = 0 start ; !ordinal wanted
if wp_type = tp_type start ; !same base-type
true if wp_type = wanted; !base-type (rather than subrange)
lo = lower(wanted); hi = upper(wanted)
if item = 0 start ; !literal
true if lo <= value <= hi
jammy = jammy!!1
else
jammy = jammy!!1 and true if tp_type = t
l = lower(t); h = upper(t)
if l >= lo start
true if h <= hi
jammy = jammy!!1
true if l <= hi
else
jammy = jammy!!1
true if h >= lo
finish
finish
expfault(rangerr) if jammy # 0
true
finish
else if wc = realy
true
else if wc = stringy; !string wanted
true if wanted = stringstar
if item = 0 start
true if value = 0; !empty string
l = final(value)+1
else
l = |tp_size|
l = 256 if l = 0
finish
if l > |wp_size| # 0 start
jammy = jammy!!1
expfault(rangerr) if item = 0 and jammy # 0
finish
true
!<
else if wc&cat = arry
true if wp_type = tp_type and valok(wp_xtype,tp_xtype)
!<
else ; !record etc
if wanted = recstar start
true if t # recstar
else
true if t = recstar or item!value = 0
finish
finish
else ; !category difference
if tc = inty start
true if wc = recy and item!value = 0; !RECORD = 0
toreal and true if wc = realy; !REAL = INT
else if wc = stringy and t = chartype; !STRING = CHAR
if item = 0 start
final(cad) = 1; final(cad+1) = value
value = cad; cad = cad+2
type = stringtype
finish else putexp(dtostring,normitem,0,string1)
true
!<
! sets again
!<
finish
finish
false
end
!
routine GET VALUE(integer valtype)
get EXPRESSION(major,valtype)
end ; !GET VALUE
!
routine GET LITERAL(integer valtype)
literal = literal+2
get EXPRESSION(major,valtype)
literal = literal-2
end
!
!!!!!!!!!!!!!!!!!!!!!! Machine-code !!!!!!!!!!!!!!!!!!!!!!!!!!
!
routine GET MIDENT(integer min,max)
get(ident)
if item <= 0 start
name error if string(charlim) # "sp"
item = a7
ditem == dict(item)
finish
if ditem_mode = litmode start
value = ditem_val; item = 0
finish
syntax error unless min <= item <= max -
or min <= ditem_mode+d0 <= a7 {in case reg alias}
end
routine GET REGSET
integer hold,set
set = 0
cycle
get mident(d0,a7)
hold = ditem_mode
get mident(hold,a7) if a(minus)
cycle
set = set!1<<hold
hold = hold+1
repeat until hold > ditem_mode
repeat until not a(slash)
value = set {item = reg if singleton}
end
routine get MCODE
integer op,x,y,types
integer fn OPSIZE(integer okbyte)
result = 0 if not a(dot)
sym = byteinteger(fp)&(\casebit); fp = fp+1
result = 4 if sym = 'L'
result = 2 if sym = 'W'
result = 1 if sym = okbyte
syntax error
end
routine get MOP(integer i)
!Get Mcode operand
integer sign,hold,holdval,m
if a(hashsign) start
get LITERAL(inttype)
return
finish
sign = 0; hold = -1; holdval = 0
sign = 1 if a(minus)
if a(ident) start
matched = 0
get mident(0,dlim)
hold = item
if hold # 0 start
syntax error if sign # 0
if item > a7 start
matched = 0; literal = -1
get EXPRESSION(simple,0)
return
finish
if op&255 = movem and item > 0 start
matched = 0
get regset; item = 0
finish
return
finish
holdval = value
else if a(const)
hold = 0; holdval = value
finish
holdval = -holdval if sign # 0
if a(left) start
get mident(a0,a7)
item = ditem_mode+d0
if hold < 0 start
get(right)
if sign # 0 then item = item+pre c
else if not a(plus) then item = item+indir c
else item = item+post
return
finish
m = item+(dispmode-a0)
if a(comma) start
get mident(d0,a7)
fault(rangerr) unless is mite(holdval)
m = m+(indexmode-dispmode)
holdval = ditem_mode<<12+holdval&255
holdval = holdval+16_0800 if opsize(0) # 2
finish
get(right)
else
syntax error if hold < 0
m = absmode
finish
item = i; ditem == dict(item)
ditem_mode = m; ditem_val = holdval
end
constinteger TEMPDEF='t'<<25+('e'&31)<<20+('m'&31)<<15+('p'&31)<<10
update sp
!Pack mnemonic
atomp = fp+1
x = 0
cycle
sym = byteinteger(fp); fp = fp+1
exit unless 'A' <= sym&(\casebit) <= 'Z'
sym = sym&31
x = x<<5+sym
repeat
fp = fp-1; sym = 0
syntax error if x = 0
x = x<<5 until x&(31<<25) # 0
x = x!16_C0000000
if x = tempdef start
c_free = defaultfree
if a(ident) start
matched = 0; get regset
c_free = value
else if a(const)
c_free = value
finish
return
finish
find op(x,op,types)
if types&(sized!qsized) # 0 then op = op+opsize('B')<<8 -
else if types&asized # 0 then op = op+opsize(0)<<8
x = 0; y = 0
if types>>6&63 # 0 start
get MOP(lablim)
x = normitem
get(comma)
finish
if types&63 # 0 start
get MOP(lablim+1)
y = normitem
finish
plant(op,x,y)
forget regs; c_access = -1
end ; !get MCODE
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
predicate REFOK(integer wanted,t)
record (identinfo)name wp,tp
true if t = wanted or wanted = 0 or t = 0 or item!value = 0
wp == dict(wanted); tp == dict(t)
if (wp_flags!!tp_flags)&(name+packed+cat) = 0 start
if wp_flags&cat = arry start
!**check index compatible
true if refok(wp_type,tp_type)
else if wp_flags&cat = stringy
true if t = stringstar or wanted = stringstar
!<
!<
else
true if t = recstar or wanted = recstar
finish
finish
false
end
routine TOREF
atomp=expp and error(nonref+point) if item <= 0 -
or (ditem_mode < dispmode and ditem_flags >= 0)
if item >= dictlim start
if ditem_act = prel and (ditem_y < 0 or ditem_type = bytetype) start
value = ditem_y
value = litref(litval(value)*|size(ditem_type)|) if ditem_type # bytetype
putexp(add,ditem_x+ad,value,ditem_type)
return
finish
else
if ditem_mode = absmode and ditem_flags >= 0 start
item = 0; value = ditem_val
return
finish
finish
item = item+ad
end
!
routine COPY DOWN(integer np1)
while np > np1 cycle
np = np-1; explo = explo-1
dict(explo) = dict(np)
repeat
end
routine GET REFERENCE(integer type)
get EXPRESSION(simple,type!sign16)
end
routine GET VARIABLE(integer type)
get EXPRESSION(simple,type)
atomp=expp and error(nonvar+point) if ditem_flags&(writable!typeid) = 0
end
routine GET PARLIST(integer special)
integer procnp,pact,hold,count,headitem,arg,p,q,restype
record (identinfo)name hp,tp
record (identinfo)name darg
routine PUT ACTUAL
item = litref(value) if item = 0
if count&1 = 0 then hold = item c
else putact(pact,hold,item) and pact = 0
count = count+1
end
predicate NO ALT(record (identinfo)name oldhp)
if oldhp_flags&alt = 0 start ; !no alternative
expfault(typerr)
true
finish
headitem = oldhp_hlink
cycle
report(internerr,0,6) and signal fail if headitem <= 0
hp == dict(headitem)
exit if string(hp_text+char0) = string(oldhp_text+char0)
headitem = hp_hlink
repeat
pact = headitem
arg = hp_type; darg == dict(arg); restype = darg_type
arg = darg_link; darg == dict(arg)
false
end
routine PUT BOUNDS(integer ft{formal-type},at{actual-type})
integer maxarg=arg
record (identinfo)name ftp,atp,fxp,axp
cycle
ftp == dict(ft); atp == dict(at)
if ftp_xtype >= arg start
fxp == dict(ftp_xtype); axp == dict(atp_xtype)
if fxp[1]_mode # litmode start ; !non-literal lower
item = atp_xtype+1
item = 0 and value = axp[1]_val if axp[1]_mode = litmode
put actual
maxarg = ftp_xtype+1 if ftp_xtype >= maxarg
finish
if fxp[2]_mode # litmode start ; !non-literal upper
item = atp_xtype+2
item = 0 and value = axp[2]_val if axp[2]_mode = litmode
put actual
maxarg = ftp_xtype+2 if ftp_xtype+1 >= maxarg
finish
finish
ft = ftp_type; at = atp_type
repeat until ft <= arg
arg = maxarg; darg == dict(arg)
end
count = 0; hold = 0
procnp = np
headitem = item; pact = headitem; hp == ditem
arg = hp_type; darg == dict(arg); restype = darg_type
if a(left) start
cycle
arg = darg_link
if arg = 0 start
error(toomany+point) if special = 0
get VARIABLE(0)
value = item; !save extra item
cycle
if type = realtype start
exit if restype = realtype; !no coercion
else
exit if valok(type,restype)
finish
repeat until no alt(hp)
special = 0
else
darg == dict(arg)
if darg_flags&proc # 0 start
get(ident)
name error if item <= 0
fault(typerr+point) if ditem_flags&proc = 0 c
or not parmatch(darg_type,ditem_type)
fault(classerr+point) if item > headitem -
and ditem_mode = procmode {procparm OK?}
item = item+ad
put actual
else if darg_flags >= 0
jammy = 0
get EXPRESSION(major,0)
cycle
exit if valok(darg_type,type)
repeat until no alt(hp)
putexp(check,darg_type,item,darg_type) if jammy # 0 c
and control&capbit # 0 c
and category(darg_type) < realy
put actual
else ; !name
get REFERENCE(0)
cycle
exit if refok(darg_type,type)
repeat until no alt(hp)
put actual
tp == dict(darg_type)
if tp_flags&cat = arry c
and dict(arg+1)_type # darg_type c
and tp_mode >= framemode start
!array name (last in group) with dynamic bounds
put bounds(darg_type,type)
finish
finish
finish
repeat until not a(comma)
error(toofew+point) if darg_link # 0 or special # 0
get(right)
else ; !no LEFT
error(toofew+point) if darg_link # 0
finish
put act(pact,hold,0) if count&1 # 0 or count = 0
type = restype
if type # 0 start ; !not routine
if hp_flags&volatile = 0 start
p = explo
while p < explim cycle
if dict(p)_act = headitem start ; ![enough?]
item = p; q = procnp
cycle
exit if dict(p)_x # dict(q)_x or dict(p)_y # dict(q)_y
p = p+1; q = q+1
->okf if q >= np
repeat
finish
p = p+1
repeat
finish
copy down(procnp)
item = explo
okf:ditem == dict(item)
ditem_flags = hp_flags&heritable
ditem_mode = 0
if hp_flags&writable # 0 start ; !map
ditem_mode = dispmode
finish
ditem_type = type
np = procnp
finish
end ; !get PARLIST
!<
routine get RESOLUTION(integer t,item1)
integer fore,ftype,s
! type check needed
s = size(t)
s = -256 if s = 0
fore = 0
if not a(left) start
get VARIABLE(stringstar)
fore = item+ad; ftype = type
get(dot); get(left)
finish
get VALUE(stringtype); get(right)
if item = 0 start
item = litref(value); s = s+final(value)
finish
fault(rangerr+warn) if fore # 0 and s < size(ftype) # 0
putact(resolves,item1+ad,item+ad) {RESOLVES expects %names ?}
item = 0
if a(dot) start
get VARIABLE(stringstar)
fault(rangerr+warn) if s < size(type) # 0
item = item+ad
finish
putact(0,fore,item)
putact(0,0,0); !preserve 'parity'
end
integer fn ANON(record (objinfo)name d)
dict(lablim+3)_details = d
result = lablim+3
end
predicate A ASSOP(integer t)
jammy = 0
if t <= 0 start
false if not a(eqeq)
else
atom = next atom if matched # 0
if atom # equals start
false unless atom = less and byteintegeR(fp) = '-'
jammy = 1; fp = fp+1
finish
matched = 1
finish
true
end
!<
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
routine GET EXPRESSION(integer rank,etype)
!Main expression recognition routine
!To bring together the treatment of all binary operators
! and ensure fast recognition of simple expressions,
! expressions of different levels are handled by
! precedence techniques rather than syntactically
integer atomp0,item1,type1,cat1,val1,double,op
record (identinfo)name ditem1,tp
constinteger nop=0; !to distinguish from numeric zero in OPVAL
routine GET RECORD
![literal only at this stage]
integer fid,ad,arg,hold,count,max,s
record (identinfo)name darg,fidp
fill code(1) if cad&1 # 0
ad = cad
fid = item; fidp == ditem
arg = fidp_link
count = 0; max = -1
get(left)
cycle
![*beware premature lexical coding: may alter CAD*]
cycle
error(toomany+point) if arg <= 0
darg == dict(arg)
exit if ad+darg_val-cad >= 0
arg = darg_hlink
repeat
fill code(ad+darg_val-cad)
! [*now OK to code atom*]
if a(recsub) start
dformat == fidp
subbed = 1; get(ident); subbed = 0
name error if item < arg
fill code(ditem_val-darg_val)
arg = item; darg == ditem
syntax error if not a assop(darg_flags&name+darg_type)
finish
s = nsize(darg)
if not a(comma) start
get LITERAL(darg_flags&name+darg_type)
if s > 0 start
if s = 4 start
!$IF VAX
{ value = ieee(value) %if darg_type = realtype %and darg_flags >= 0
!$FINISH
set code longword(value)
%else %if s = 2
set code word(value)
%else
final(cad) <- value; cad = cad+1
%finish
%finish
%exit %if a(right)
get(comma)
%else %if s > 0
fill code(s)
%finish
arg = darg_hlink
%repeat
fill code(ad+|fidp_val|-cad)
item = 0; value = ad
%end
%routine SWOP
%integer temp
temp = item1; item1 = item; item = temp
temp = val1; val1 = value; value = temp
temp = type1; type1 = type; type = temp
%end
%constinteger INTOK=1<>(cat1&cat)&1 = 0 %start
%if cat1 = inty %and ok&realok # 0 %start
toreal; cat1 = realy
%else %if ok&stringok # 0 %and valok(stringtype,type)
cat1 = stringy
%else
fault(typerr+point)
%finish
%finish
type1 = type; item1 = item; val1 = value
%end
%integer%fn FROZEN LIT(%integer t,v)
! Used when the type of a literal will not be recoverable from context
%integer hold,res
hold = item
putexp(move,0,litref(v),t); !NO-OP (distinctive Y)
ditem_flags = okflag+wflag
ditem_mode = constmode; ditem_val = v
res = item; item = hold
%result = res
%end
%routine COERCE(%integer c)
%if c = inty %and cat1 = realy %start
toreal
%else %if cat1 = inty %and c = realy
![rather sloppy]
%if item1 # 0 %start
val1 = item; item = item1
toreal
item1 = item; item = val1
%finish %else real(addr(val1)) = val1
type1 = realtype; cat1 = realy
%else
expfault(typerr)
%finish
%end
%routine GET ARITH(%integer rank)
get EXPRESSION(rank,0)
rank = category(type)
coerce(rank) %if rank # cat1
%end
%integer%fn RCOND(%integer op)
%constinteger EQUAL=2_1001000010,
LESS =2_1010000001,
GREATER=2_0101000001
%integer which,c
!<= 0
double = item
%else %if double < 0
double = -2
%finish
!< 0 %or item1!val1 = 0 %or item!value = 0 %start
!non-structure (compile-time)
![integer tests ok for real?]
%if val1 < value %then which = less %c
%else %if val1 = value %then which = equal %c
%else which = greater
%result = which>>(op-bne)&1
%finish
item1 = frozen lit(type1,val1)
%else
swop
op = op!!3 %if op&8 # 0; !no change for '=','#'
%finish
%finish
%result = op
%end; !RCOND
!< op(atom)
op(plus):
check1(numok+setok)
get ARITH(star)
%if cat1 = inty %start
%if item1 = 0 %start
%result = val1+value %if item = 0
swop
%finish
%result = nop %if item!value = 0
type = inttype
%result = add
%else
%if item1 = 0 %start
%if item = 0 %start
real(addr(val1)) = real(addr(val1))+real(addr(value))
%result = val1
%finish
swop
%finish
%result = nop %if item!value = 0
%result = fadd
%finish
op(minus):
check1(numok+setok)
get ARITH(star)
%if cat1 = inty %start
%if item1 = 0 %start
%result = val1-value %if item = 0
swop %and %result = neg %if val1 = 0
%finish
type = inttype
%if item = 0 %start
%result = nop %if value = 0
value = -value %if value # minint
%result = add
%finish
%result = sub
%else
%if item = 0 %start
%if item1 = 0 %start
real(addr(val1)) = real(addr(val1))-real(addr(value))
%result = val1
%finish
%result = nop %if value = 0
%finish
%result = fsub
%finish
op(exclam):
check1(intok); get EXPRESSION(star,inttype)
%if item1 = 0 %start
%result = val1!value %if item = 0
swop
%finish
%result = nop %if item!value = 0
type = inttype
%result = or
op(exclam2):
check1(intok); get EXPRESSION(star,inttype)
%if item1 = 0 %start
%result = val1!!value %if item = 0
swop
%finish
%result = nop %if item!value = 0
type = inttype
%result = eor
op(ampersand):
check1(intok); get EXPRESSION(star2,inttype)
%if item1 = 0 %start
%result = val1&value %if item = 0
swop
%finish
item1 = 0 %and %result = 0 %if item!value = 0
type = inttype
%result = and
op(star):
check1(numok+setok)
get ARITH(star2)
item1 = 0 %and %result = 0 %if item!value = 0
%if cat1 = inty %start
%if item1 = 0 %start
%result = val1*value %if item = 0
swop
%finish
val1 = type; type = inttype
%result = muls %if control&halfbit # 0
%result = imul %if type1 = inttype
%if item = 0 %start
%result = imul %if value&(value-1) = 0 {power of 2}
val1 = value
else
val1 = lower(type); value = upper(type)
finish
result = mulop(lower(type1),upper(type1),val1,value)
else
if item1 = 0 start
if item = 0 start
real(addr(val1)) = real(addr(val1))*real(addr(value))
result = val1
finish
swop
finish
result = fmul
finish
op(over):
check1(intok); get EXPRESSION(star2,inttype)
if item = 0 start
fault(rangerr) and result = nop if value = 0
result = val1//value if item1 = 0
finish
type = inttype
result = idiv
op(slash):
check1(realok)
get EXPRESSION(star2,realtype)
if item = 0 start
fault(rangerr) and result = nop if value = 0
if item1 = 0 start
real(addr(val1)) = real(addr(val1))/real(addr(value))
result = val1
finish
finish
result = fdiv
op(backslash2): op(uparrow2):
check1(intok); get EXPRESSION(simple,inttype)
if item = 0 start
result = val1\\value if item1 = 0
item1 = 0 and result = 1 if value = 0
result = nop if value = 1
item = item1 and result = imul if value = 2
finish
type = inttype
result = ipow
op(backslash): op(uparrow): op(star2):
check1(realok)
get EXPRESSION(simple,inttype)
type = realtype
if item!item1 = 0 start
real(addr(val1)) = real(addr(val1))\value
result = val1
finish
result = fpow
op(lshift):
check1(intok); get EXPRESSION(simple,inttype)
if item = 0 start
result = val1<<value if item1 = 0
result = nop if value = 0
finish
type = inttype
result = lsl
op(rshift):
check1(intok); get EXPRESSION(simple,inttype)
if item = 0 start
result = val1>>value if item1 = 0
result = nop if value = 0
finish
type = inttype
result = lsr
op(tilde):
check1(intok)
get EXPRESSION(simple,inttype)
result = \value if item = 0
swop
type = inttype
result = not
op(sconc):
check1(stringok); get EXPRESSION(dot+1,stringtype)
if item = 0 start
if item1 = 0 start
result = val1 if value = 0
result = value if val1 = 0
if final(val1)+final(value) <= 255 start
string(final0+val1) = string(final0+val1) c
. string(final0+value)
cad = cad-1
finish else fault(rangerr)
result = val1
finish
result = nop if value = 0
else if item1!val1 = 0
item1 = item; val1 = value; type1 = type
result = nop
finish
type = stringtype
result = concat
op(equals):
result = RCOND(beq)
op(noteq):
result = RCOND(bne)
op(lesseq):
result = RCOND(ble)
op(less):
result = RCOND(blt)
op(greateq):
result = RCOND(bge)
op(greater):
result = RCOND(bgt)
integer fn RACOND(integer op)
toref
item1 = normitem; type1 = type
get REFERENCE(type1)
val1 = 0 and swop if item1 = 0
syntax error if arrow <= atom <= greater
double = -2
result = op
end
op(eqeq):
result = RACOND(beq)
op(noteqeq):
result = RACOND(bne)
op(arrow):
check1(stringok)
item1 = litref(val1) if item1 = 0
get RESOLUTION(type,item1)
item1 = np-3
condop = bne!!polarity
type1 = booltype
result = nop
op(keyand):
topred if condop = 0
item1 = np; type1 = booltype
putact(condop!!polarity!!1+polarity<<7,item,0)
condop = 0
get EXPRESSION(scond,booltype)
dict(item1)_y = item
syntax error if a(keyor)
result = nop
op(keyor):
topred if condop = 0
item1 = np; type1 = booltype
putact(condop!!polarity+(polarity!!1)<<7,item,0)
condop = 0
get EXPRESSION(scond,booltype)
dict(item1)_y = item
syntax error if a(keyand)
result = nop
end
routine PUT INDEX(integer op)
integer size,lo,hi
if item = 0 and ditem1_flags&(name+indirect) = 0 -
and (item1 < dictlim or ditem1_act < 0) start
size = 1; lo = 0
get array info(tp,size,lo,hi) if op # sindex
if size # 0 and lo # minint start {known lower bound}
putexp2(-op,item1,tp_type)
ditem_mode = ditem1_mode; ditem_val = ditem1_val+(value-lo)*|size|
return
finish
finish
putexp2(op,item1,tp_type)
ditem_mode = ditem1_mode
end
!Get leading operand
atom = next atom if matched # 0
atomp0 = atomp; jammy = jammy<<1; !preserve
if atom = ident start
matched = 1
name error if item <= 0 or (ditem_mode = labmode and item < c_localdpos)
fault(namerr+point) if item >= dlim0
type = ditem_type
if ditem_flags&typeid # 0 start
item1 = item; ditem1 == ditem
if a(less) start ; !typeid - type coercion
get VALUE(0); get(greater)
type = item1
else if ditem_flags&cat = recy and item > dnil
get RECORD
return
else
get(left); !store mapping
get VALUE(inttype)
get(right)
putexp2(storemap,item1,item1)
ditem_flags = writable!readable
ditem_mode = dispmode
finish
else if ditem_mode = litmode
item = 0; value = ditem_val
else ; !non-literal ident
cycle
if ditem_flags&proc # 0 start
if item = daddr or item = dsizeof or item = dnew start
get(left)
item1 = item
get REFERENCE(0)
if item1 = daddr start
type = inttype
else
value = |size(type)|
expfault(sizerr) if value = 0
if item1 = dsizeof start
item = 0; type = inttype
else
putexp(dnew,0,litref(value),0)
ditem_mode = dispmode
finish
finish
get(right)
! %else %if item = dsnl
! putexp(dtostring,nl,0,string1)
else
exit if literal < 0 {proc name only}
get PARLIST(0)
atomp=atomp0 and error(classerr+point) if type = 0; !routine
finish
else ; !not procedure
atom = next atom if matched # 0
exit unless aleft <= atom <= recsub and rank <= simple
matched = 1
if atom = aleft start ; !array subscript
cycle
item1 = item; ditem1 == ditem
tp == dict(type)
if tp_flags&cat = stringy start
nonstandard(2)
get VALUE(bytetype)
put index(sindex)
else
syntax error unless tp_flags&cat = arry
get VALUE(tp_xtype); !get index
put index(index)
finish
ditem_flags = ditem1_flags&heritable
repeat until not a(comma)
ditem_flags = ditem_flags+(tp_flags&name)
get(right)
else if atom = recsub; !record subfield
item1 = item; ditem1 == ditem
dformat == dict(ditem_type)
syntax error unless dformat_flags&cat = recy
subbed = 1; get(ident); subbed = 0
error(namerr+point) if item <= 0
val1 = ditem_flags; val1 = val1!ditem1_flags&heritable
! val1 = ditem1_flags&heritable!ditem_flags
if (ditem1_flags&(name+indirect) = 0 -
or ditem1_mode&2_111000 = aregmode) -
and (item1 < dictlim or ditem1_act < 0) start
{compile-time ad eval}
value = ditem_val
putexp2(-recref,item1,ditem_type)
ditem_mode = ditem1_mode; ditem_val = ditem1_val+value
if ditem_mode&2_111000 = aregmode -
then ditem_mode = ditem_mode+(dispmode-aregmode)
else
putexp2(recref,item1,ditem_type)
ditem_mode = ditem1_mode
finish
ditem_flags = val1
else if atom = atsign
nonstandard(4)
syntax error if ditem_flags&typeid = 0
ditem1 == ditem; item1 = item
get EXPRESSION(vsimple,inttype)
putexp2(storemap,item1,item1)
ditem_flags = writable!readable
ditem_mode = dispmode
else ; !leftb: pointer relative
error(nonref+point) if ditem_mode < dispmode
fault(sizerr) if size(ditem_type) = 0
ditem1 == ditem; item1 = item
get VALUE(inttype); get(rightb)
putexp2(prel,item1,ditem1_type)
ditem_flags = writable!readable
ditem_mode = ditem1_mode
finish
finish
repeat
finish
else
if atom = const start
matched = 1
else if atom = minus; !leave unmatched
item = 0; value = 0; type = inttype
else if atom = left
matched = 1
if rank < major start ; !condition
get EXPRESSION(condq,0)
else
get EXPRESSION(major,0)
finish
get(right)
else if atom = hashsign
matched = 1; literal = literal-8
get REFERENCE(0)
literal = literal+8
type = inttype
else if a(keynot)
syntax error if rank >= major
polarity = polarity!!1
get EXPRESSION(scond,booltype)
if item = 0 then value = value!!1
polarity = polarity!!1
else if atom = backslash
item = 0; value = 0; type = inttype
atom = tilde
else if a(modsign)
get EXPRESSION(major,0)
if valok(inttype,type) start
if item = 0 start
if value < 0 start
if value # minint then value = -value else expfault(rangerr)
finish
else
putexp2(iabs,0,inttype)
finish
else if valok(realtype,type)
putexp2(fabs,0,realtype)
else
error(typerr+point)
finish
get(modsign)
else
syntax error
finish
finish
atom = next atom if matched # 0; ![always primed on return]
if etype < 0 start ; !reference required
expp = atomp0; jammy = jammy>>1; !restore
unless item!value = 0 start ; !*temp*
toref
expfault(typerr) if not refok(etype-sign16,type)
finish else atomp = atomp0 and nonstandard(21)
else
while atom >= rank cycle
matched = 1
double = -1
op = opval
if item1!item = 0 start ; !both literal
if double # -1 start
if double >= 0 start
literal = literal+2; !enforce all literal
op = op&opval
literal = literal-2
finish
type = booltype
finish
value = op
else if double = -1; !not relop
if op # 0 start
item1 = litref(val1) if item1 = 0
putexp(op,item1,normitem,type)
else ; !nop
item = item1; type = type1
finish
else ; !conditional operation
condop = op!!polarity
putact(compare,item1,normitem)
item = np-1
if double >= 0 start
putact(condop!!polarity!!1+polarity<<7,np-1,np+1); !implicit %and
item = double; ![TYPE,VALUE unchanged]
matched = 1
op = opval
error(nonliteral) if item1!item = 0; !mixed non-lit, lit
condop = op!!polarity
putact(compare,item1,normitem)
item = np-2
finish
type = booltype
finish
repeat
expp = atomp0; jammy = jammy>>1
if etype # 0 start
if type = booltype start
topred if (rank = cond or rank = scond) and condop = 0
finish
expfault(typerr) if not valok(etype,type)
finish
finish
if (literal > 0 and item # 0) -
or (literal < 0 and item >= dictlim and ditem_act >= 0) start
atomp = expp; error(nonliteral+point)
finish
end ; !get EXPRESSION
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!! Conditions and loops !!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
routine GET CONDITION
integer maxlab,condnp
routine ASSIGN LABELS(integer p,lab,pol)
integer base=maxlab
record (identinfo)name dp
while (p-condnp)&1 # 0 cycle ; !compound
dp == dict(p); p = dp_y
if dp_act&1<<7 = pol then assign labels(dp_x,lab,pol) c
else maxlab = base+1 and assign labels(dp_x,maxlab,pol!!1<<7)
repeat
dp == dict(p+1); dp == dp[2] if dp_act = 0; !resolution
if maxlab > base then dp_x = maxlab and maxlab = base c
else dp_x = 0
dp_y = lab
dp_act = dp_act&127
end
condnp = np
polarity = subatom; condop = 0
get EXPRESSION(cond,booltype)
putact(condop!!1,item,0)
return if faultnum > 0
maxlab = curlab+1
assign labels(item,maxlab,0)
end ; !get CONDITION
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
routine DO DYNAMIC ARRAYS
update sp
c_mode = c_mode!2_01000000; !bar to SP rel addressing
c_status = c_status!globbed; !needs link
while c_dynarray # 0 cycle
if c_dynarray < 0 then putact(aget,-c_dynarray,one) c
else putact(aget,c_dynarray,0)
c_dynarray = dict(|c_dynarray|)_link
repeat
compile(np0)
end
routine GET STATEMENTS(integer stopper)
! STOPPER = 0 -- initial call
! -1 -- %section
! 1 (END) -- for procedure or block body
! 2 (REPEAT) -- for loop body
! 3 (FINISH) -- for condition body (ELSE not valid)
! 4 (ELSE) -- " (ELSE valid)
switch initial(0:atommax)
integer forinf,endval,loopstart
routine THIS IS INST
if c_status < hadinst start ; !first in block
c_status = c_status+hadinst
fault(ordererr) if stopper <= 0
finish
fault(accesserr+warn) if c_access = 0 and np = np0
do dynamic arrays if c_dynarray # 0
end
routine PUTACT2(integer act,item1)
putact(act,item1,normitem)
end
routine GET RESULT
get VALUE(c_type)
! fault(rangerr+warn) %if c_type > 0 %and item # 0 %c
! %and |size(type)| > |size(c_type)|
end
routine GET INSTRUCTION
integer item1
record (identinfo)name tp
this is inst
cycle
if a(ident) start
name error if item <= 0
if ditem_flags&(writable!typeid) # 0 start
matched = 0
get EXPRESSION(simple,0)
item1 = item
if a(equals) start
jammy = 0
get VALUE(type)
putact2(okass+jammy,item1); !okass,assign
else if a(eqeq)
syntax error if ditem_flags >= 0
get REFERENCE(type)
putact2(assign,item1+ad)
else if atom = less and byteintegeR(fp) = '-'
fp = fp+1; matched = 1
jammy = 1
get VALUE(type)
putact2(jamass+jammy,item1); !jamass,okass
else
syntax error if not a(arrow)
get RESOLUTION(type,item1)
putact(bne,0,curlab)
putact(signal,litref(7),undef)
putact(0,undef,undef)
finish
else
error(classerr+point) if ditem_flags&proc = 0
tp == dict(ditem_type)
if tp_type # 0 start ; !function as routine
get PARLIST(tp_type)
putact2(assign,value)
else
get PARLIST(0)
finish
finish
else
c_access = 0 if np = np0; !unconditional
if a(keymonitor) start
c_access = 1
! fault(monitor<<8)
else if a(exit); !%exit, %continue
if c_looplab = 0 then fault(notinloop+point) c
else putact(jumpout,c_looplab,c_looplab+subatom)
exit
else if a(keyreturn)
item = 0; value = 0
get RESULT if c_type # 0
putact2(return,0)
exit
else if a(keyresult)
error(notinfun+point) if c_type = 0
syntax error if not a assop(c_type)
get RESULT
putact2(return,0)
exit
else if a(tf); !%true, %false
if c_type # booltype then fault(notinpred+point) c
else putact(return,0,litref(subatom))
exit
else if a(arrow) or a(keygoto)
nonstandard(5) if atom = keygoto
get(ident)
if byteinteger(fp) # '(' start
declare(forwardlabel) if item < c_localdpos {new} c
or ditem_type # 0 {error}
putact2(goto,0)
else
name error if item < c_localdpos
error(classerr+point) unless ditem_mode = labmode c
and ditem_type # 0
item1 = item
get(left)
get VALUE(dict(ditem_type)_xtype); !index
get(right)
putact2(swgoto,item1)
finish
exit
else if a(keystop)
putact(stop,0,0)
exit
else if a(keysignal)
c_access = 1
allow(keyevent)
get LITERAL(inttype)
expfault(rangerr) unless 0 <= value <= 15
item1 = litref(value); item = undef
if a(comma) start
l1: if a(comma) then matched = 0 else get VALUE(bytetype)
finish
putact2(signal,item1)
item = undef
if a(comma) start
l2: if a(comma) then matched = 0 else get VALUE(inttype)
finish
item1 = normitem; item = undef
get VALUE(stringtype) if a(comma)
putact2(0,item1)
exit
else
syntax error
finish
finish
repeat until not a(keyand)
end ; !GET INSTRUCTION
routine GET FOR CLAUSE
!Global: FORINF,ENDVAL
integer loopvar,lvtype,k,s,start,sval,i,inc,ival,e,n
integer end
record (identinfo)name tp
forinf = 0
get(ident)
name error if item <= 0
lvtype = ditem_type; tp == dict(lvtype)
fault(typerr+point) if tp_flags&nonord # 0
loopvar = item
get(equals)
get VALUE(lvtype)
start = item; sval = value
get(comma)
get VALUE(lvtype)
inc = item; ival = value
expfault(rangerr) and ival = 1 if inc = 0 = ival
!Deal with INC and replace START by START-INC
k = undef
k = dict(start)_y if start >= np0 and dict(start)_act = add
if inc = 0 start ; !literal increment
i = litref(ival)
if start = 0 start ; !START and INC both literal
sval = sval-ival; item = litref(sval)
else if k <= 0; !START is x+lit
k = litval(k)-ival
item = dict(start)_x
putexp(add,item,litref(k),inttype) if k # 0
else
putexp(add,start,litref(-ival),inttype)
finish
else ; !variable
i = inc
if control&volbit # 0 start
declare temp(inttype); i = item
putact(assign,i,inc); forinf = forinf-4
finish
if start = inc start ; !identical
item = 0; sval = 0
else if k = inc; !START is x+INC
item = dict(start)_x
else
item = start; item = litref(sval) if item = 0
putexp(sub,item,i,inttype)
finish
finish
s = item
!Get end-value
get(comma)
get VALUE(lvtype)
end = item
if end = 0 start ; !literal end-value
e = litref(value); endval = value
else
e = item
if control&volbit # 0 start
declare temp(inttype); e = item
putact(assign,e,end); forinf = forinf-4
finish
finish
if start!inc!end # 0 and control&loopbit # 0 start
putact(forass,loopvar,s)
putact(forass,i,e)
else
putact(assign,loopvar,s)
finish
putact(label,curlab,0)
if start!inc!end = 0 start ; !all literal
k = endval-sval; n = k//ival
if n = 0 start
fault(dubious+warn)
putact(else,0,curlab+1); !ie unconditional branch
return
finish
fault(boundserr) if n < 0
fault(unending) if n*ival # k
forinf = loopvar
else
putact(compare,loopvar,e)
putact(beq,0,curlab+1)
finish
putact(incass,loopvar,i)
end ; !get FORCLAUSE
routine GET LOOP BODY
integer hold=c_looplab
c_looplab = curlab; curlab = curlab+2
get STATEMENTS(keyrepeat)
curlab = curlab-2; c_looplab = hold
end
routine GET SWITCH INDEX
integer i
record (identinfo)name dp,tp
routine SET LABEL(shortname p)
value = p
expfault(duperr) if value > 0
set user label(value)
p = value
end
dp == ditem; tp == dict(ditem_type)
get(left)
if a(star) start
set label(dp_link)
else
get VALUE(tp_xtype)
!beware faulty declaration or index
if tp_xtype > inttype and faultnum = 0 start
i = value-lower(tp_xtype)+dp_val
c_forward = c_forward-1 if i < pc; !(had goto)
set label(prog(i))
finish
finish
get(right)
end
![unsure of efficiency implications of trapping overflow lower down]
on event oflow,fail,done start
if event_event = 0 start ; !failure in %option,%include or ^Y
stop if event_sub # 0
signal abandon
finish
if event_event = done start
croak("Premature end of input") if stopper # 0
close block
c_dpid_val = 0; !zero entry-point
return
finish
fault(rangerr+now) if event_event = oflow
-> ignore
finish
!!!!!!!!!!!!!!!!!!! Start of new statement !!!!!!!!!!!!!!!!!!!
next:
statements = statements+1
compile(startnp) if np > np0
define label(curlab) if dict(curlab)_val < 0
define label(curlab+1) if dict(curlab+1)_val < 0
next1:
report(faultnum,0,0) if faultnum # 0
dlim0 = dlim; dmin = dmin0
speccing = 0; subbed = 0
literal = 0; jammy = 0; condop = 0
dict(curlab)_val = 0; dict(curlab+1)_val = 0
np = np0; startnp = np0
maxcalldreg = maxdreg; maxcallareg = maxareg
zaps = zaps+1 and forget all if explo < np0+50
zaps = zaps+1000 and forget all if litpos > litmax-40
value = 0
!
initial(terminator):
atom = next atom; matched = 1
-> initial(atom)
{initial(keycomment):} initial(exclam): initial(exclam2):
comments = comments+1
read line(0)
-> next1
term:
get(terminator)
-> next
ignore:
c_access = -1
if atom # terminator start
cycle
subatom = atom; atom = next atom
repeat until atom = terminator
starts = starts+1 if subatom = keystart
cycles = cycles+1 if subatom = keycycle
finish
-> next1
initial(dud):
syntax error; !ie atom error
routine get IEF
!Get IF(+1), ELSE(0), FINISH(-1) after dollar-sign
! update CCOND accordingly
percent = 1 {fool NEXT ATOM}
if a(iu) start
value = 1; ccond = ccond<<2!3
else
error(noif) if ccond = 0
if a(keyelse) start
value = 0
else
get(keyfinish)
value = -1; ccond = ccond>>2
finish
finish
end
routine get CCOND
integer hold=ccond>>2
cycle
if value > 0 start {$IF}
literal = 1; condop = 0; polarity = subatom
syntax error if polarity # 0
get EXPRESSION(equals,booltype) {get condition}
return if value # 0 {condition true}
finish
{Ignore}
cycle
cycle
read line('-')
cycle
sym = byteintegeR(fp); fp = fp+1
repeat until sym # ' '
repeat until sym = '$'
matched = 1
get ief
if value < 0 start {$FINISH}
return if ccond = hold
else if value = 0 and ccond>>2 = hold {$ELSE}
error(noif) if ccond&1 = 0
percent = 1
value = 1 {$ELSE IF}
ccond = ccond-1 and percent = 0 and return if not a(iu)
exit
finish
repeat
repeat
end
initial(dollar):
get ief
if value >= 0 start {$IF, $ELSE}
error(noif) if value = 0 and ccond&1 = 0 {$ELSE after $ELSE}
get ccond
finish
-> term
initial(*):
error(nonstarter+point)
initial(ident):
if byteintegeR(fp) = ':' start ; !simple label
fp = fp+1
declare(definedlabel)
set user label(ditem_val)
->next
finish
name error if item <= 0
if ditem_mode = labmode and ditem_type # 0 start
literal = 1
get SWITCH INDEX
get(colon)
->next
finish
initial(keyreturn): initial(keyresult): initial(tf):
initial(keystop): initial(keysignal): initial(keymonitor):
initial(exit): initial(keygoto): initial(arrow):
matched = 0
get INSTRUCTION
-> next if a(terminator)
c_access = 1
if a(iu) start
startnp = np
get CONDITION
else if a(keywhile)
putact(repeat,curlab,0); !append repeat
startnp = np
define label(curlab)
get CONDITION
else if a(keyfor)
putact(0,0,0)
putact(0,0,0)
putact(repeat,curlab,0); !append repeat
startnp = np
get FOR CLAUSE
value = np; np = startnp-3
if forinf > 0 start
putact(compare,forinf,litref(endval))
putact(beq,0,curlab)
finish else np = np+2
putact(repeat,curlab,forinf)
np = value
else
syntax error if not a(keyuntil)
get CONDITION
putact(repeat,curlab,0)
define label(curlab)
finish
-> term
initial(iu): !if , unless
this is inst
cycle
get CONDITION
if a(keythen) and not a(keystart) start
get INSTRUCTION
else
matched = 0; ![unsee %start]
get(keystart)
cycle
get(terminator)
curlab = curlab+2
get STATEMENTS(keyelse)
curlab = curlab-2
exit if atom # keyelse; !%finish ->
putact(else,curlab+1,curlab)
-> exit2 if not a(iu)
get CONDITION
repeat
-> initial(keyend) if atom = keyend
finish
-> term if not a(keyelse)
putact(else,curlab+1,curlab)
repeat until not a(iu)
if not a(keystart) start
get INSTRUCTION
else
exit2:
get(terminator)
curlab = curlab+2
get STATEMENTS(keyfinish)
curlab = curlab-2
-> initial(keyend) if atom = keyend
finish
-> term
initial(keycycle):
this is inst
if a(terminator) start
define label(curlab)
get LOOP BODY
->initial(keyend) if atom = keyend
get CONDITION if a(keyuntil)
putact(repeat,curlab,0)
-> term
finish
nonstandard(22)
get FOR CLAUSE
-> for1
initial(keywhile):
this is inst
define label(curlab)
get CONDITION
get(keycycle)
get(terminator)
compile(np0)
get LOOP BODY
-> initial(keyend) if atom = keyend
nonstandard(6) and get CONDITION if a(keyuntil)
putact(repeat,curlab,0)
->term
initial(keyfor):
this is inst
get FOR CLAUSE
get(keycycle)
for1:
get(terminator)
compile(np0)
if forinf > 0 start ; !Literal for loop
!%continue must come to end for increment
loopstart = dict(curlab)_val; !save start position
dict(curlab)_val = 0
finish
get LOOP BODY
-> initial(keyend) if atom = keyend
if forinf > 0 start ; !literal FOR loop
define label(curlab)
dict(curlab)_val = loopstart; !restore
putact(compare,forinf,litref(endval))
putact(beq,0,curlab)
finish
putact(repeat,curlab,forinf)
-> term
initial(keyon):
fault(ordererr+point) if c_status >= hadon or stopper <= 0
do dynamic arrays if c_dynarray # 0
c_status = c_status!hadon
matched = 1
allow(keyevent)
dump = 0
cycle
get LITERAL(inttype)
expfault(rangerr) unless 0 <= value <= 15
dump = dump!1<<value
repeat until not a(comma)
get(keystart)
putact(settrap,0,litref(dump))
curlab = curlab+2
get STATEMENTS(keyfinish)
curlab = curlab-2
-> initial(keyend) if atom = keyend
-> term
!
initial(keyelse):
-> ignore if starts # 0
return if stopper = keyelse
error(noif) if stopper = keyfinish
initial(keyfinish):
starts = starts-1 and -> ignore if starts # 0
return if stopper = keyfinish or stopper = keyelse
error(nostart)
initial(keyrepeat):
cycles = cycles-1 and -> ignore if cycles # 0
return if stopper = keyrepeat
error(nocycle)
routine LOW
if control&lowbit = 0 start
fault(lowlevel+warn+point); control = control!lowbit
finish
end
initial(star):
low
matched = 1
if byteinteger(fp) = '=' start
fp = fp+1
get LITERAL(inttype)
plant(dc,0,temp(absmode,value))
else
get MCODE
finish
->term
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!! Declarations !!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
routine DECLARE LIT RANGE(integer basetype,lo,hi)
own record (objinfo) D=0
fault(boundserr) and hi = lo if lo > hi
item = ranges
cycle
ditem == dict(item)
item = item-2 and return if ditem_val = hi and ditem_type = basetype c
and ditem[-1]_val = lo
item = ditem_hlink
repeat until item = 0
declare anon(d); !blank (for updating)
declare range(basetype,lo,hi)
end
routine DECLARE STRING TYPE(integer size)
item = stringtype and return if size = -256
item = string1 and return if size = -2
item = ranges
cycle
ditem == dict(item)
return if ditem_size = size and ditem_type = chartype
item = ditem_hlink
repeat until item = 0
declare anon(details(typeid+stringy,chartype,0,0))
ditem_size = size
ditem_hlink = ranges; ranges = item
end
routine GET LIT RANGE(integer basetype)
integer holdval
get LITERAL(basetype); holdval = value
get(colon)
get LITERAL(basetype)
declare lit range(basetype,holdval,value)
end
routine GET IDENTLIST(record (objinfo)name d)
dlim0 = dlim
get(ident) and declare(d) until not a(comma)
end
routine RECALIGN(integername val)
align(val,2)
val = -val if val > 4
end
routine GET DECLARATION(integer FLAGS,MODE,integer name DISP,integer DEPTH)
record (objinfo) DECL
record (identinfo)name DFHOLD
owninteger ITEMTYPE=0,ITEMSIZE=0,ADIM=0
integer BASE,HOLD,MAX,STMAX,DREG,AREG
routine spec GET VAR BOUND
routine GET DATA TYPE
switch s(ktype:keyname)
atom = next atom if matched # 0
syntax error unless ktype <= atom <= keyname
matched = 1
-> s(atom)
s(ktype):
itemtype = inttype+subatom
itemsize = size(itemtype)
nonstandard(7) if itemtype >= mitetype
allow(keyinteger)
return
s(keyinteger): !integer
itemtype = inttype; itemsize = 4
if a(left) start
nonstandard(8)
get LIT RANGE(inttype)
get(right)
itemtype = item
itemsize = |dict(itemtype)_size|
finish
return
s(keylong): !long
itemtype = inttype; itemsize = 4; !**for now**
if a(keyinteger) then fault(notin+point+warn) c
else itemtype = realtype and get(keyreal)
return
s(keyreal): !real
itemtype = realtype; itemsize = 4
return
s(keystring): !string
itemsize = 0
if a(left) start
atom = next atom
! %if depth # 0 %and ktype <= atom <= keyinteger %start
! get VAR BOUND
! itemtype = stringstar
! %else %if a(star)
if a(star) start
itemtype = stringstar
else
get LITERAL(bytetype)
itemsize = -(value+1)
declare string type(itemsize)
itemtype = item
finish
get(right)
else
syntax error if mode # constmode
itemtype = stringtype
finish
return
s(keyrecord): !record
get(left)
if not a(star) start
if not a(ident) start
declare anon(typeident)
hold = item; dfhold == dformat
dformat == ditem
get DECLARATION(writable+readable,0,dformat_val,0)
recalign(dformat_val)
ditem == dformat
dformat == dfhold; item = hold
finish
name error if item <= 0
error(classerr+point) if ditem_flags&(\spec) # typeid+recy
itemtype = item; itemsize = ditem_val
else
itemtype = recstar; itemsize = 0
finish
get(right)
return
s(keyname): !untyped name - leave unmatched
itemtype = 0; matched = 0
end
routine ASSIGN ADDRESS(integer size)
routine ASSIGN STACK ADDRESS
align(stmax,2); ditem_val = stmax
stmax = stmax+|size|
c_status = c_status!onstack if depth = 1 and speccing = 0
end
integer fn MAXFREE(integer regset)
integer r=a7
if regset = 0 start
fault(plexerr)
else
r = r-1 and regset = regset<<1 while regset&16_8000 = 0
finish
result = r
end
size = -4 if ditem_flags&(name+indirect) # 0
if mode # 0 and decl_mode&2_110000 = 0 start ; !%register
if decl_mode # a7-d0 start {register given}
decl_mode = decl_mode+1 {for next time}
else if depth # 0 {parameter}
if size > 0 start
fault(plexerr) if dreg > maxcalldreg
ditem_mode = dreg-d0; dreg = dreg+1
else
fault(plexerr) if areg > maxcallareg
ditem_mode = areg-d0; areg = areg+1
finish
else
if size > 0 start
ditem_mode = maxfree(c_free&(anydreg-bregb))-d0
else
ditem_mode = maxfree(c_free&anyareg)-d0
finish
finish
if depth # 0 start
ditem_reg = ditem_mode
dlink_link = item; dlink == ditem
finish
c_free = c_free&(\(1<<ditem_mode)) if speccing = 0
ditem_val = 0
return
finish
if depth # 0 start
dlink_link = item; dlink == ditem
if size > 0 start
!simple value
if dreg > maxcalldreg start
assign stack address
return
finish
remember(dreg,item) if speccing = 0
ditem_reg = dreg-d0; dreg = dreg+1
else
if areg > maxcallareg start
assign stack address
ditem_reg = 8 {would have been AREG}
return
finish
remember(areg,item+ad) if speccing = 0 and ditem_flags < 0
ditem_reg = areg-d0; areg = areg+1
finish
finish
ditem_val = disp
if ditem_mode&2_11000000 # static start
disp = disp+|size|
if ditem_mode >= framemode start
align(disp,2) {*always kept even*}
ditem_val = c_sp-disp; !neg stack disp.
finish
finish
end
!
routine FIELD IDENT
head == dformat_link; item = head
if item > 0 start
cycle
ditem == dict(item)
fault(duperr+point) if string(ditem_text+char0) = string(charlim)
head == ditem_hlink; item = head
repeat until item <= 0
finish
end
!<
routine DUMP CONST(integer v,n)
! Plant N replications of value V (of type ITEMTYPE and size ITEMSIZE)
! For simple operand V is value, otherwise V is address in FINAL
! Alignment requirement has been enforced (since it depends on context)
integer i,j,k,kk,vv
k = itemsize
if k <= 0 start ; !structure
k = -k
k = final(v)+1 if k = 0; ![string]
cad = v if v # 0; !reset cad
finish
kk = k
return if n < 1
kk = kk*n if n > 1
if mode = constmode start
i = cad; cad = cad+kk
croak("Program too big") if cad >= initbase
if v = 0 start
final(i) = 0 and i = i+1 until i >= cad
return
finish
else
if v = 0 start
run(ownmode,ownval,kk,v)
ownval = ownval+kk
return
finish
pattern(ownmode,ownval,kk)
make init room(kk)
i = initlim; initlim = initlim+kk
ownval = ownval+kk
finish
if itemsize <= 0 start ; !structure
while n > 0 cycle
n = n-1; j = i+k
vv = v
cycle
final(i) = final(vv)
i = i+1; vv = vv+1
repeat until i =j
repeat
else
!$IF VAX
{ v = ieee(v) %if itemtype = realtype; !vax->ieee
!$FINISH
%while n > 0 %cycle
n = n-1
%if itemsize >= 2 %start
%if itemsize > 2 %start; !longword
final(i) <- v>>24
final(i+1) <- v>>16
i = i+2
%finish
final(i) <- v>>8
i = i+1
%finish
final(i) <- v
i = i+1
%repeat
%finish
%end; !dump const
!<= framemode %start
ditem_flags = ditem_flags!mflag
assign address(4)
%finish
%end
%routine GET ARRAY DECLARATION(%integer dim)
%integer pos,dlim1,holdval,holdz,jam,elements,totsize,lo1,size1
%record(identinfo)%name dp
%ownrecord(objinfo) ATYPE=0
%integer%fn XTYPE
declare anon(details(typeid,inttype,0,0))
%result = item
%end
%routine GET REST
%integer e,r,lo,loval,hi,hival
r = 0
atom = next atom %if matched # 0
%if decl_flags < 0 %start; !%array%name
%if depth > 0 %and ktype <= atom <= keyinteger %start; !variable
r = xtype; get VAR BOUND
%else %if a(star)
fault(notin+point)
r = xtype; declare bound(decl_mode,0)
%else
get LITERAL(inttype)
%finish
%else; !%array
get VALUE(inttype)
%finish
loval = value; lo = item
loval = minint %if lo # 0
get(colon)
atom = next atom %if matched # 0
%if decl_flags < 0 %start
%if depth > 0 %and ktype <= atom <= keyinteger %start; !variable
%if r = 0 %start
r = xtype; declare bound(litmode,loval)
%finish
get VAR BOUND
%else
%if dim!r = 0 %and a(star) %start
item = 0; value = maxint
%else
get LITERAL(inttype)
declare bound(litmode,value) %if r # 0
%finish
%finish
%else
get VALUE(inttype)
%finish
hival = value; hi = item
hival = maxint %if hi # 0
e = maxint
%if r = 0 %start; !no range yet declared
%if lo!hi = 0 %start
e = hival-loval %if hival!!loval >= 0 %or minint+hival-loval < 0
e = e+1 %if e # maxint
e = 0 %if hival = maxint
declare lit range(inttype,loval,hival)
%else
declare anon(typeident); !blank (for updating)
declare range(inttype,loval,hival)
%finish
r = item
%finish
elements = e
%if a(comma) %start
dim = dim+1
get REST
%if elements # maxint %and e # maxint %start
elements = elements*e
%else
elements = maxint
%finish
%finish
atype_xtype = r
size1 = totsize; lo1 = loval; !for outer dimension
%if elements = maxint %start; !non-literal bounds
atype_mode = mode
declare anon(atype)
atype_type = item; !save type id
%if decl_flags >= 0 %or (depth = 1 %and speccing = 0) %start
lo = litref(loval) %if lo = 0
hi = litref(hival) %if hi = 0
putact(asize,item,litref(totsize))
putact(0,lo,hi)
%if decl_flags >= 0 %start
compile(np0)
dict(r+1)_mode = c_mode %and dict(r+1)_val = c_sp+4 %if lo > 0
dict(r+2)_mode = c_mode %and dict(r+2)_val = c_sp %if hi > 0
%finish
%finish
totsize = 0
%else; !literal bounds
item = 0
%cycle
ditem == dict(item)
%exit %if ditem_type = atype_type %and ditem_xtype = atype_xtype %c
%and ditem_flags = atype_flags
item = item+1
%if item = dlim %start
declare anon(atype)
%exit
%finish
%repeat
atype_type = item
totsize = totsize*e
%finish
%end; !get REST
%routine PUT BOUNDS
%integer i
i = xtype; !index type
declare bound(mode,0); !lower
declare bound(mode,0); !upper
dim = dim-1
put bounds %if dim > 0
atype_xtype = i
declare anon(atype); !array type
%if speccing = 0 %start
putact(asize,item,litref(totsize))
putact(0,i+1,i+2)
%finish
totsize = 0; lo1 = minint
atype_type = item
%end
pos = dlim0; dlim1 = dlim; dp == ditem
atype_flags = typeid+arry+okflag; atype_type = itemtype
%if atype_type < 0 %start
atype_flags = atype_flags+name; atype_type = atype_type-name
%finish
atype_mode = constmode
totsize = |itemsize|
%if dim > 0 %start; !%array(n)%name
atype_mode = mode
put bounds
elements = maxint
%else; !left parenthesis recognised
get REST
get(right)
%finish
dp_type = atype_type
%if mode&2_11000000 # static %start {dynamic array}
holdval = d0
while pos # dlim1 cycle
dp == dict(pos)
dp_type = atype_type
if mode >= framemode start
dp_flags = dp_flags!arrflag if lo1 = minint or size1 = 0
if decl_flags >= 0 start ; !%array not %array%name
if totsize # 0 {all literal bounds} c
and totsize<<1-c_sp+disp <= 32000 start
!if array will occupy less than half remaining reach
!then allocate directly on stack
disp = disp+totsize
align(disp,2)
else
fault(ordererr) if c_mode&2_01000000 # 0; !hard order error
if totsize # 0 start ; !known bounds but too big
c_extra = c_extra+totsize
holdval = litref(totsize)
finish
![ADOK updates C_SP]
holdz = 0; holdz = litref(-lo1*size1) if dp_flags&arrflag = 0
putact(adok,holdval,holdz); !compute & store space needed
compile(np0)
dp_flags = dp_flags+indirect
dp_link = c_dynarray
c_dynarray = pos; c_dynarray = -c_dynarray if holdz # 0
c_status = c_status!unknown
holdval = 0
finish
dp_val = c_sp-disp
finish
else if decl_flags >= 0; !record field or absolute
!name already allocated
dp_val = disp; disp = disp+totsize
finish
pos = pos+1
repeat
else ; !const,own
if decl_flags&(name+indirect) # 0 start
syntax error if mode = constmode
disp = disp+4
else
if a assop(itemtype) start
jam = jammy
dp_flags = dp_flags!okflag; ![hum]
allow(terminator)
cycle
jammy = jam
get VALUE(itemtype)
faultnum = rangerr+point+warn if faultnum = rangerr+point
holdval = value
value = 1
if a(left) start
value = elements
get LITERAL(halftype) if not a(star)
get(right)
finish
elements = elements-value
value = value+elements if elements < 0
dump const(holdval,value)
repeat until not a(comma)
if faultnum = 0 and elements # 0 start
if elements < 0 then report(counterr,pos,elements) c
else report(counterr+warn,pos,elements)
finish
finish
if elements > 0 start
elements = elements*|itemsize|
if mode = constmode then fill code(elements) -
else disp = disp+elements
finish
finish
finish
end ; !get ARRAY DECLARATION
!
routine GET PROCEDURE DECLARATION
integer pos,dlim1,argmode,argad,restype,stack
record (identinfo)name headditem,dhold
predicate DUPOK
!Check that the proc being declared can reasonably alias existing id
record (identinfo)name tp
false if ditem_flags&proc = 0
tp == dict(ditem_type)
if restype = 0 start ; !routine
false if tp_type # 0 or tp_link = 0; !not routine, or no pars
else
false if restype = tp_type; !function of same type
finish
true
end
restype = itemtype
stack = 0; !unknown
decl_flags = decl_flags&(\okflag)
decl_type = procstar; !by default
if mode = 255 start ; !mode not explicit
mode = procmode; decl_val = 0
if decl_flags&ext = 0 start ; !not external
decl_flags = decl_flags+spec if a(keyspec)
decl_flags = decl_flags!proc1
else if a(keyspec)
mode = ownmode
decl_flags = decl_flags+(spec+indirect)
finish
else if depth # 0; !procedure as param
decl_flags = decl_flags!proc2; ![must push MB in case external]
else ; !@...
decl_flags = decl_flags!proc1
decl_val = disp
stack = 4
finish
decl_mode = mode
if {decl_flags&ext # 0 %and} a(keyalias) start
nonstandard(9)
get(ident)
if item <= 0 start
fault(namerr+point)
else
item = 0 and decl_flags = decl_flags!alt if dupok
finish
else
get(ident)
finish
declare(decl)
headditem == ditem
assign address(-6) if depth # 0
argmode = c_mode&(\2_01000000)+1
if decl_flags&spec # 0 or decl_mode # procmode start
speccing = speccing+1
else
c_forward = c_forward-1 if ditem_flags&rflag # 0
open block(item)
c_type = restype
if c_type # 0 start
c_type = c_type!sign16 if decl_flags&writable # 0 {%map}
c_status = c_status!okcc
finish
finish
dlim1 = dlim
declare anon(details(0,restype,0,stack))
ditem_reg = 8 if restype # 0 and (decl_flags&writable # 0 {%map} -
or size(restype) <= 0 {structure fn}); !result @A0
!Declare parameters
argad = c_sp; !ok for both spec and body
if a(left) start
dhold == dlink; dlink == ditem
get DECLARATION(okflag+writable+readable,argmode,argad,1)
dlink == dhold
get(right)
finish
if speccing # 0 start
speccing = speccing-1
pos = crunched(dlim1)
if pos < dlim1 or speccing = 0 start
headditem_type = pos
else ; !proc as param
fault(classerr); dlim = dlim1
finish
else ; !procedure body
if c_dpid_flags&spec # 0 start
c_dpid_flags = c_dpid_flags-spec
if not parmatch(c_dpid_type,dlim1) start
if c_pid = dlim1-2 then fault(matcherr+warn) c
else fault(matcherr)
finish
finish
headditem_type = dlim1
c_parlim = dlim
c_sp = -argad
compile(np0)
get(terminator)
get STATEMENTS(keyend)
finish
end ; !get procedure declaration
routine GET INITIAL VALUE(record (identinfo)name dp)
if itemtype >= 0 and itemsize > 0 {value,simple} -
and a(query) start
prompt(string(char0+dp_text).": ")
item = 0; read(value)
finish else get VALUE(itemtype)
dp_flags = dp_flags!okflag
if mode = constmode start
if itemtype < 0 start ; !name
dp_flags = writable+readable
dp_mode = absmode; dp_val = value
else
faultnum = rangerr+point+warn if faultnum = rangerr+point
if itemsize <= 0 then dump const(value,1) c
else dp_mode = litmode and dp_val = value
finish
else if static <= mode < framemode; !own
faultnum = rangerr+point+warn if faultnum = rangerr+point
dump const(value,1)
else ; !dynamic initialisation
atomp = expp and nonstandard(1) if item # 0
if itemtype < 0 start
putact(okass,dlim0+ad,normitem)
else
putact(okass+jammy,dlim0,normitem)
finish
compile(np0)
finish
end ; !get initial value
dreg = d0; areg = a0; stmax = 8; !allow for RETAD & LINK
max = 0; base = disp
cycle
disp = base
cycle
decl = 0
decl_flags = flags; decl_mode = mode
adim = -1
while a(kattrib) cycle
if subatom = 3 start ; !%register
low
decl_mode = a7-d0; decl_val = c_free
if a(left) start
get regset
if value&(value-1) = 0 start {unit set}
decl_mode = item-d0
else
decl_val = decl_val&value; ![*for use later*]
finish
get(right)
finish
else
decl_flags = decl_flags!!(1<<subatom)
finish
repeat
if depth = 0 and a(left) start ; !start of sub-group
! align(disp,2)
! ad_cat = ad_cat+1 %if mode = 0
get DECLARATION(flags,mode,disp,0); get(right)
! ad_cat = ad_cat-1 %if mode = 0
else if a(rpred); !%routine,%predicate
if subatom # 0 start ; !pred
decl_flags = decl_flags&(\(writable))
decl_flags = decl_flags!volatile if control&volbit # 0
itemtype = booltype
else
decl_flags = decl_flags&(\(writable+readable))
itemtype = 0
finish
get PROCEDURE DECLARATION
return if depth = 0
else
get DATA TYPE
!Appendages
if a(fnmap) start ; !%fn, %map
decl_flags = decl_flags!volatile if control&volbit # 0
if subatom = 0 start
decl_flags = decl_flags&(\writable)
fault(illstarred) if itemsize = 0
finish
get PROCEDURE DECLARATION
return if depth = 0
else
decl_flags = decl_flags&(\proc)
decl_type = itemtype
if a(keyname) start
decl_flags = decl_flags+name; itemtype = itemtype+name
itemsize = 4
finish
if a(keyarray) start
fault(illstarred) if itemtype = recstar
adim = 0
decl_flags = decl_flags&(\name); decl_type = arrstar
decl_flags = decl_flags!arrflag if control&arrbit # 0
if a(left) start
fault(notin+point) if depth = 0
get LITERAL(inttype)
if value&(\7) # 0 then expfault(rangerr) else adim = value
get(right)
get(keyname); matched = 0
finish
decl_flags = decl_flags+name if a(keyname)
finish
if decl_mode = 255 start ; !not explicitly specified
if decl_flags&ext = 0 start ; !main declaration
fault(notinblock) if stopper <= 0
if c_status >= hadon start
if c_forward!c_return # 0 or curlab # c_lab1 start
fault(ordererr)
else if c_status&hadordererr = 0
fault(ordererr+warn); c_status = c_status+hadordererr
finish
finish
mode = c_mode
else if a(keyspec); !external spec
mode = ownmode
decl_flags = decl_flags!(spec+indirect)
else ; !external
mode = ownmode; disp == ownval
finish
decl_mode = mode
finish
fault(illstarred) if itemsize = 0 and decl_flags >= 0 -
and decl_mode # constmode -
and decl_mode&63 # absmode
!Read identifier list
cycle
dlim0 = dlim
unless decl_type = arrstar start {not array}
if disp&1 # 0 start
align(disp,2) unless itemsize = 1 -
or (itemtype > 0 and category(itemtype)&cat = stringy) -
or literal >= 99
finish
if not a(ident) start
get(star)
disp = disp+|itemsize|
else
subbed = 0
field ident if mode = 0
declare(decl)
assign address(itemsize)
if mode # 0 and depth = 0 start
if decl_flags&spec = 0 start
if a assop(itemtype) start
get INITIAL VALUE(ditem)
else if mode = constmode
syntax error
else if static <= mode < framemode
disp = disp+|itemsize|
finish
finish else disp = disp+4
finish
finish
else {array}
align(disp,2) unless literal >= 99
cycle
get(ident)
field ident if mode = 0
declare(decl)
assign address(0) {(4 if name)}
exit if not a(comma)
atom = next atom
if atom # ident start
if adim = 0 start
syntax error if decl_flags >= 0
adim = 1
finish
get ARRAY DECLARATION(adim)
-> exit22
finish
repeat
if adim # 0 or not a(left) start
if adim = 0 start
syntax error if decl_flags >= 0
adim = 1
finish
get ARRAY DECLARATION(adim)
-> exit2
finish
get ARRAY DECLARATION(adim)
finish
-> exit2 if not a(comma)
atom = next atom
repeat until atom # ident and atom # star
exit22:
continue
finish
finish
exit if not a(comma); ![NB %continue above]
repeat
exit2:
max = disp if disp > max
repeat until not a(keyor)
disp = max
end ; !get declaration
initial(keyconst):
literal = 1
get DECLARATION(okflag+readable,constmode,cad,0)
-> term
routine GET ADDRESS(integer name mode,val)
routine GET AD
get EXPRESSION(major,inttype)
if item # 0 start
error(nonliteral) unless a0 <= item <= a7
mode = item+(dispmode-a0)
else
val = val+value
if a(left) start
get ad; get(right)
finish
finish
end
mode = absmode; val = 0
get ad
end
initial(keyown):
if a(equals) start
low
get address(ownmode,ownval)
else
literal = 1
get DECLARATION(writable+readable,ownmode,ownval,0)
finish
-> term
routine GET AT(integer flags)
integer mode,val
low
if a(hashsign) start {@# ident}
literal = -1
get EXPRESSION(simple,0)
if item <= dlim and a(plus) start {increment actual ident address}
literal = 1
get DECLARATION(ditem_flags&(writable+readable+okflag),
ditem_mode,ditem_val,0)
return
finish
mode = ditem_mode; val = ditem_val
else
get address(mode,val)
finish
mode = mode!static if a(keyown)
literal = 99
get DECLARATION(flags!(okflag+writable+readable),mode,val,0)
end
initial(atsign):
get at(0)
-> term
initial(keyext):
fault(ordererr) if level # 0
literal = 1
dump = subatom<<12
if a(atsign) start
get at(dump)
else
if a(leftb) start
get LITERAL(inttype); get(rightb)
maxcalldreg = (d0-1)+value&15
maxcallareg = (a0-1)+value>>4&15
dump = dump!!(value&(\255))
finish
get DECLARATION(dump!(writable+readable),255,ownval,0)
finish
-> term
initial(keyrecord):
if not a(left) start
get(keyformat)
if a(keyspec) start
typeident_flags = typeid+spec+recy
get(ident); declare(typeident)
else
typeident_flags = typeid+recy
get(ident); declare(typeident)
get(left)
dformat == ditem
get DECLARATION(writable+readable,0,dformat_val,0)
recalign(dformat_val)
get(right)
finish
-> term
finish
fp = fp-1; atom = keyrecord; !back-up
initial(ktype): initial(keylong):
initial(keyinteger): initial(keyreal):
initial(kattrib): initial(keystring):
initial(rpred):
matched = 0
get DECLARATION(writable+readable,255,c_val,0)
-> term
initial(keylabel):
get IDENTLIST(forwardlabel)
-> term
routine GET SWITCH DECLARATION
integer i,lo,hi,dlim1
ownrecord (objinfo) d=0
matched = 1
cycle
d_type = arrstar; !(in case of error)
d_flags = d_flags+arrflag if control&arrbit # 0
d_mode = labmode
get IDENTLIST(d)
dlim1 = dlim
declare anon(details(typeid+arry,0,0,0))
get(left); get LIT RANGE(inttype); get(right)
dict(dlim1)_xtype = item
lo = lower(item); hi = upper(item)
cycle ; !For each ident in group
for i = lo,1,hi cycle
swpc = swpc-1; prog(swpc) = 0
croak("Code space exhausted") if swpc <= pc
repeat
dict(dlim0)_val = swpc
dict(dlim0)_type = dlim1
dlim0 = dlim0+1
repeat until dlim0 = dlim1
repeat until not a(comma)
end
initial(keyswitch):
literal = 1
get SWITCH DECLARATION
c_status = c_status!hadswitch
->term
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!! Control statements !!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
routine OPT
integer c=control
set options(string(final0+value))
select output(listout); !**for now - PAM may alter**
control = control&(\list) if (initcon!c)&list = 0
control = control!list if control&(\c)&(ttlist+codelist+explist+dictlist) # 0
end
initial(keyoption):
get LITSTRING
get(terminator)
opt if faultnum = 0
-> next
initial(keyinclude):
get LITSTRING
get(terminator)
if faultnum = 0 start
croak("Too many nested includes") if curfile = 3
line = line+1 if sym = nl
cur_fp = fp; cur_line = line
fcontrol(curfile) = control
control = control&(\list) if control&(codelist+explist+dictlist) = 0
curfile = curfile+1
lastfile = -1 if curfile = lastfile
cur == file(curfile); cur = 0
time1 = time1-cputime
define param("INC",cur_name,nodefault)
opt
connect edfile(cur)
time1 = time1+cputime
signal abandon if cur_flag # 0
line = 0; sym = nl
curstart = cur_start2; curlim = cur_lim2
fp = cur_start2
finish
->next
initial(keycontrol):
get LITERAL(inttype)
control = 0 if value = 0
control = control!!value
show dict(0) if control&dictlist # 0
->term
initial(keylist):
control = control!list
->term
!initial(keysection):
initial(keycomment): !*for testing*
get(terminator)
error(ordererr) if stopper # 0
c_parlim = dlim; c_localtext = charlim
get STATEMENTS(-1)
check usage(c_parlim)
-> term
initial(keybegin):
get(terminator)
if stopper = 0 start ; !first %begin
c_localdpos = dlim; c_parlim = dlim
c_access = 1
get STATEMENTS(keyend)
return
finish
declare anon(beginblock)
open block(dlim0)
get STATEMENTS(keyend)
update sp
this is inst
srcall(dlim-1)
-> term
initial(keyend):
if stopper > keyend start
if stopper = keyrepeat then fault(norepeat+now) -
else fault(nofinish+now)
![caller will revert to INITIAL(KEYEND)]
else
if a(keyof) start
if a(keylist) start
control = control&(\list)
->term
finish
if a(keyfile) start
fp = curlim; sym = nl
->next
finish
get(keyprogram)
fault(noend+now) if level # 0
finish
fault(nobegin+now) if stopper = 0
if c_access > 0 start
fault(noresult+now) if c_type # 0; !fn/map/pred
finish
close block if stopper >= 0
finish
end ; !GET STATEMENTS
!<
routine ANNOUNCE(integer value,string (255) message)
write(value,1); space; printstring(message)
printsymbol('s') if value # 1
end
routine OUTPUT OBJECT FILE
constinteger OBJOUT=1
integer i,reset,totsize
reset = 0
end run; end pattern
if initlim # initbase start
if inithead >= 0 start ; !copy routine needed
set code word(16_205F); ! move.l (sp)+,a0
set code word(16_3018); ! move.w (a0)+,d0
set code word(16_32D8); !l1 move.w (a0)+,(a1)+
set code word(16_51C8); ! dbra d0,l1
set code word(-4)
set code word(16_4ED0); ! jmp (a0)
finish
reset = cad; !entry-point for RESET
put own word(16_4E75); ! rts
finish
totsize = cad+(initlim-initbase); !total code size
set extension(objfile,".mob")
time1 = time1-cputime
open output(objout,objfile)
select output(objout)
put word(16_FE02); !object module flag, version
put word(control>>20<<4); !checking options
value = 0
do externals(externs,-1) if externs # 0; !find size
put word(value); !length of exports
value = 0
do externals(extspecs,-1) if extspecs # 0; !find size
put word(value); !length of imports
put word(totsize>>16); !length of code + init pattern
put word(totsize)
put word(reset>>1); !reset entry-point
put word(c_dpid_val>>1); !main entry-point
ownval = 0 if ownmode # defaultownmode {not good enough}
put word(ownval>>16); !static data requirement
put word(ownval)
put word(c_totstack>>16); !stack requirement
put word(c_totstack)
put word(0); !spare for diag
put word(0)
put word(0)
put word(0)
do externals(externs,0) if externs # 0
do externals(extspecs,1) if extspecs # 0
final(0) = 16_4E; final(1) = 16_75; !RTS (as null reset,main?)
i = 0
cycle
print symbol(final(i)); i = i+1
repeat until i = cad
if initlim # initbase start
i = initbase
cycle
print symbol(final(i))
i = i+1
repeat until i = initlim
finish
time1 = time1+cputime
end
routine CLOSE EDIT
!_FLAG is negative if edit abandoned
!_CHANGE is untouched (inf) if no changes
if file(main)_flag >= 0 and 0 < file(main)_change # 16_7FFFFFFF start
file(main)_name = mainfile; ![in case modified by OPEN IN]
time1 = time1-cputime
disconnect edfile(file(main))
printstring(file(main)_name." updated"); newline
time1 = time1+cputime
finish
end
begin
on event redo,abandon start
close edit and stop if event_event = abandon
finish
time2 = cputime-time1
statements = 1; comments = 0; atoms = 0
identatoms = 0; litatoms = 0
faults = 0; others = 0; faultnum = 0
zaps = 0; steps = 0; jumps = 0; shorts = 0
rep = ""
forget triples; !reset LITPOS,EXPLO,OLDEXPLO
char0 = addr(char(0)); final0 = addr(final(0))
preset
dint == dict(inttype)
dtemp == dict(lablim); dtemp2 == dtemp[1]
dtsprel == dtemp2[1]
dtemp = 0; dtemp2 = 0; dtsprel = 0
dmin = dictlim; dmin0 = dmin
inclim = 0
accounted = 0
firstentry = finalbound; firstpos = dictlim
pc = 1; swpc = progbound+1
cad = 2
final(0) = 0; !for empty string (compile-time only)
initbase = finalbound-4095; initlim = initbase
inithead = -1; initmode = 255; initval = 0
initd1 = -1; initrep = 0; initdata = 0
ownmode = defaultownmode; ownval = 0
level = 0; vintage = 1
pendout = 0; pendin = 0; polarity = 0
curlab = dictlim+1
reset context(procstar,defaultfree)
c_sp = -4; !allow for BSR
control = initcon; ccond = 0
lastfile = main
curfile = main; cur == file(main)
curstart = file(main)_start1; curlim = file(main)_lim1
fp = file(main)_start1
line = 0; sym = nl
np = np0
!<
get STATEMENTS(0)
!<
end
time2 = cputime-time2-time1
close edit
output object file if faults = 0 or control&forcebit # 0
cycle
select output(listout)
printstring(file(main)_name)
if faults = 0 or control&forcebit # 0 start
printstring(" compiled:")
announce(statements,"statement")
print string(" (+")
announce(comments,"comment")
printstring(") to")
announce(cad,"byte")
printstring(" (+"); write(initlim-initbase,1)
printsymbol(')')
newline
finish
if faults # 0 start
printsymbol(':')
announce(faults,"fault")
printstring(" reported")
if others # 0 start
printstring(" (+"); announce(others,"other")
printsymbol(')')
finish
newline
finish
if control&logbit # 0 start
printstring(c
" CODE OWNS JUMPS SHORT STEPS ZAPS | ATOMS LITS IDS TIME")
newline
write(cad,5)
write(ownval,5)
write(jumps,6); write(shorts,5)
write(steps,5); write(zaps,5)
print(atoms/statements,5,1)
print(litatoms/statements,2,1)
print(identatoms/statements,1,1)
print(time2/statements,2,3)
printsymbol('+')
print(time1/statements,0,3)
newline
finish
exit if listout = 0
listout = 0
repeat
!<
endofprogram