begin
!$IF ECSVAX
{%conststring(51) title = %c
{" EUCSD IMP Compiler for M68000. VAX Version 2.2g"
!$IF APM
conststring (51) title = c
" EUCSD IMP Compiler for M68000. APM Version 2.2g"
!$FINISH
!
! Hamish Dewar Computer Science Edinburgh University 1982/83/84
!
constinteger WHICH='.imp'
!<<BOTH [markers for parts common to Pascal]
!General notes:
! The main data structure DICT is used for identifier, type, label
! and expression representation (with some aliasing). The fixedsize
! cell has a number of advantages which outweigh the Procustean factor
! (and the 16-byte size is efficiently addressed)
!
! Major routines (like EVAL) which have variables heavily used by
! nested routines are not placed below level 1 for efficiency of
! addressing. (Making the compiler an external procedure rather
! than a main program would seriously impact this efficiency).
!
!!!!!!!!!!!!!!!!!! File handling definitions !!!!!!!!!!!!!!!!!!!!!
!
constinteger MAXNAME=127
string (maxname) MAINFILE,OBJFILE
! Editor-compatible file-mapping record:
recordformat EDFILE(integer start1,lim1, {part 1}
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},
NEWBIT= 16_00000040 {Pascal: new treatment of pointers},
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
!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
constinteger D0B=1, D1B=2, D2B=4, BREGB=16,
A0B=16_100, A1B=16_200, A2B=16_400
constinteger ANYDREG=16_00FF-bregb, ANYAREG=16_FF00,
ANYREG=16_FFFF
constinteger DEFAULTFREE=2<<(maxdreg-d0)-1+(2<<(maxareg-a0)-1)<<8+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,
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),
OWNMODE=2_01000000+dispmode+(mb-a0),
CONSTMODE=2_01000000+pcmode,
FRAMEMODE=2_10000000+dispmode
! + 01000000 for dynamic array
!
! 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
ownrecord (objinfo) DEFINEDLABEL=0,
FORWARDLABEL=0,
BEGINBLOCK=0,
TYPEIDENT=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,NEW,".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("OFILE",objfile,newgroup)
define param("LFILE",listfile,0)
define int param("IDents",dictlim,newgroup)
define int param("KBytes",finalbound,0)
file(main) = 0
set options(cliparam)
control = control&(¬linebit) if control&diagbit = 0; !*temp*
!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
forwardlabel_flags = spec; forwardlabel_mode = labmode
definedlabel_mode = labmode
beginblock_mode = procmode
typeident_flags = typeid+recy
!
!!!!!!!!!!!!!!!! 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
!
!
!<<IMP
!* 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,6313,-1,-4,
4098,75,0,56,0,0,
4096,42,0,56,-32767,2861,
4099,80,0,56,0,0,
0,-53,81,6144,0,4,
-32701,-63,0,6313,-1,-4,
4099,83,0,56,0,0,
0,-53,84,6144,0,4,
-32701,-63,85,6313,-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,2839,
4096,42,0,56,-32665,3097,
4096,42,0,56,-32640,2077,
4098,108,0,56,-32611,6,
0,-64,97,6144,0,4,
4096,42,0,56,-32605,2597,
4096,42,0,56,-32568,2334,
4096,42,0,56,-32538,1806,
4096,42,0,56,-32524,2626,
4096,42,0,56,-32458,2070,
4096,42,0,56,-32436,2090,
4103,116,0,56,0,16008,
0,-68,76,6144,0,4,
22786,118,0,108,0,0,
0,-59,119,0,0,0,
-32701,-63,120,6313,-1,-4,
67,-65,121,6569,-1,-260,
-32701,-63,122,6825,-1,-264,
-32701,-63,0,7081,-1,-268,
4098,124,0,56,-32394,15,
0,-65,125,6144,0,4,
-32701,-63,126,6313,-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,6313,-1,-256,
26880,159,0,108,0,0,
0,-1,160,0,0,0,
67,-44,161,169,-1,-4,
67,-65,0,6313,-1,-260,
26880,159,0,108,0,0,
4096,154,0,56,0,15960,
4096,154,0,56,0,15954,
26880,166,0,108,0,0,
0,-1,97,0,0,0,
26880,166,0,108,0,0,
26880,0,0,108,0,0,
26880,0,0,108,0,0,
4096,42,0,56,0,15936,
4096,42,0,56,0,15930,
26880,173,0,108,0,0,
0,-1,157,0,0,0,
4096,42,0,56,-32379,4,
4096,42,0,56,-32375,4,
22784,166,0,108,0,0,
22784,166,0,108,0,0,
22790,179,0,108,0,0,
0,-65,0,6144,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,
26886,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
end ; !preset
!<<BOTH
! 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,
shortarray content(d0:a7))
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)
!STATUS flag bits
constinteger UNKNOWN =16_0002,
WRONGCC =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 OUTERLEVEL=0, 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,OWNAD,JOKERAD,OWNBASE
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)
true if -32768 <= v <= 32767
false
end
predicate IS MITE(integer v)
true if -128 <= v <= 127
false
end
integer fn MITE(integer v)
v = v&255; v = v-256 if v&128 # 0
result = v
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
!
!!!!!!!!!!!!!! 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
!<<IMP
{?} 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
!<<BOTH
{?}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
!<<IMP
!! 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"
!<<BOTH
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
put sym('|')
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
mark = '?'
if n > 0 start
mark = '*'
c_faults = c_faults+1; faults = faults+1
finish
faultnum = 0; c_access = -1
!Ignore uncorrected earlier error
return if file(main)_start1 <= fp < lastchange
!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 n > reacherr and curfile = main and control&editbit # 0 start
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
else
print line
select output(listout)
time1 = time1+cputime
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 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
![EA needs to be further distinguished]
constinteger SHIFT=32
constinteger REG=1, AREG=2, IREG=3, QUICK=4, MQUICK=5,
EA=6, RWEA=7, WEA=8,
IMM=9, TQUICK=10, REL=11, LONGREL=12,
QREG=13, POSTAREG=14, QEA=15,
REVEA=16, XIMM=17, DATA=18, PREAREG=19, QPRE=20,
EXREG=21+shift
constinteger REG9=reg+shift, QREG9=qreg+shift, IREG9=ireg+shift,
POSTAREG9=postareg+shift,
QUICK9=quick+shift, AREG9=areg+shift
constinteger SIZED=1<<15, ASIZED=1<<14; !2 spare bits
constinteger REVERSIBLE=revea<<6+reg9+sized, MULTIPLE=ximm<<6+ea+asized
constinteger DEFMAX=129
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+ reversible,
'a'<<25+('d'&31)<<20+('d'&31)<<15,
{SUB} 16_9000<<16+ reversible,
's'<<25+('u'&31)<<20+('b'&31)<<15,
{CMP} 16_B000<<16+ ea<<6+reg9 +sized,
'c'<<25+('m'&31)<<20+('p'&31)<<15,
{AND} 16_C000<<16+ reversible,
'a'<<25+('n'&31)<<20+('d'&31)<<15,
{OR} 16_8000<<16+ reversible,
'o'<<25+('r'&31)<<20,
{EOR} 16_B100<<16+ reg9<<6+rwea +sized,
'e'<<25+('o'&31)<<20+('r'&31)<<15,
{NOT} 16_4600<<16+ rwea +sized,
'n'<<25+('o'&31)<<20+('t'&31)<<15,
{NEG} 16_4400<<16+ rwea +sized,
'n'<<25+('e'&31)<<20+('g'&31)<<15,
{LSL} 16_E108<<16+ qreg9<<6+reg +sized,
'l'<<25+('s'&31)<<20+('l'&31)<<15,
{LSR} 16_E008<<16+ qreg9<<6+reg +sized,
'l'<<25+('s'&31)<<20+('r'&31)<<15,
{MULS} 16_C1C0<<16+ ea<<6+reg9,
'm'<<25+('u'&31)<<20+('l'&31)<<15+('s'&31)<<10,
{DIVS} 16_81C0<<16+ ea<<6+reg9,
'd'<<25+('i'&31)<<20+('v'&31)<<15+('s'&31)<<10,
{MULU} 16_C0C0<<16+ ea<<6+reg9,
'm'<<25+('u'&31)<<20+('l'&31)<<15+('u'&31)<<10,
{DIVU} 16_80C0<<16+ ea<<6+reg9,
'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+reg +sized,
'a'<<25+('s'&31)<<20+('l'&31)<<15,
{ASR} 16_E000<<16+ qreg9<<6+reg +sized,
'a'<<25+('s'&31)<<20+('r'&31)<<15,
{ROL} 16_E118<<16+ qreg9<<6+reg +sized,
'r'<<25+('o'&31)<<20+('l'&31)<<15,
{ROR} 16_E018<<16+ qreg9<<6+reg +sized,
'r'<<25+('o'&31)<<20+('r'&31)<<15,
{MOVEQ} 16_7000<<16+ mquick<<6+reg9,
'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+rwea +sized,
'a'<<25+('d'&31)<<20+('d'&31)<<15+('i'&31)<<10,
{SUBI} 16_0400<<16+ imm<<6+rwea +sized,
's'<<25+('u'&31)<<20+('b'&31)<<15+('i'&31)<<10,
{CMPI} 16_0C00<<16+ imm<<6+ea +sized,
'c'<<25+('m'&31)<<20+('p'&31)<<15+('i'&31)<<10,
{ANDI} 16_0200<<16+ imm<<6+rwea +sized,
'a'<<25+('n'&31)<<20+('d'&31)<<15+('i'&31)<<10,
{ORI} 16_0000<<16+ imm<<6+rwea +sized,
'o'<<25+('r'&31)<<20+('i'&31)<<15,
{EORI} 16_0A00<<16+ imm<<6+rwea +sized,
'e'<<25+('o'&31)<<20+('r'&31)<<15+('i'&31)<<10,
{ROXL} 16_E110<<16+ qreg9<<6+reg +sized,
'r'<<25+('o'&31)<<20+('x'&31)<<15+('l'&31)<<10,
{ROXR} 16_E010<<16+ qreg9<<6+reg +sized,
'r'<<25+('o'&31)<<20+('x'&31)<<15+('r'&31)<<10,
{CLR} 16_4200<<16+ wea +sized,
'c'<<25+('l'&31)<<20+('r'&31)<<15,
{NEGX} 16_4000<<16+ rwea +sized,
'n'<<25+('e'&31)<<20+('g'&31)<<15+('x'&31)<<10,
{NBCD} 16_4800<<16+ rwea,
'n'<<25+('b'&31)<<20+('c'&31)<<15+('d'&31)<<10,
{PEA} 16_4840<<16+ ea,
'p'<<25+('e'&31)<<20+('a'&31)<<15,
{JSR} 16_4E80<<16+ ea,
'j'<<25+('s'&31)<<20+('r'&31)<<15,
{JMP} 16_4EC0<<16+ ea,
'j'<<25+('m'&31)<<20+('p'&31)<<15,
{TAS} 16_4AC0<<16+ rwea,
't'<<25+('a'&31)<<20+('s'&31)<<15,
{TST} 16_4A00<<16+ ea +sized,
't'<<25+('s'&31)<<20+('t'&31)<<15,
{ABCD} 16_C100<<16+ qpre<<6+reg9,
'a'<<25+('b'&31)<<20+('c'&31)<<15+('d'&31)<<10,
{SBCD} 16_8100<<16+ qpre<<6+reg9,
's'<<25+('b'&31)<<20+('c'&31)<<15+('d'&31)<<10,
{ADDX} 16_D100<<16+ qpre<<6+reg9 +sized,
'a'<<25+('d'&31)<<20+('d'&31)<<15+('x'&31)<<10,
{SUBX} 16_9100<<16+ qpre<<6+reg9 +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+ reg,
's'<<25+('w'&31)<<20+('a'&31)<<15+('p'&31)<<10,
{EXTW} 16_4880<<16+ reg,
'e'<<25+('x'&31)<<20+('t'&31)<<15+('w'&31)<<10,
{EXTL} 16_48C0<<16+ reg,
'e'<<25+('x'&31)<<20+('t'&31)<<15+('l'&31)<<10,
{EXG} 16_C140<<16+ exreg<<6+reg,
'e'<<25+('x'&31)<<20+('g'&31)<<15,
{LEA} 16_41C0<<16+ qea<<6+areg9,
'l'<<25+('e'&31)<<20+('a'&31)<<15,
{CHK} 16_4180<<16+ ea<<6+reg9,
'c'<<25+('h'&31)<<20+('k'&31)<<15,
{DBXX} 16_50C8<<16+ reg<<6+longrel,
'd'<<25+('b'&31)<<20+('x'&31)<<15+('x'&31)<<10,
{DBRA} 16_51C8<<16+ reg<<6+longrel,
'd'<<25+('b'&31)<<20+('r'&31)<<15+('a'&31)<<10,
{DBHI} 16_52C8<<16+ reg<<6+longrel,
'd'<<25+('b'&31)<<20+('h'&31)<<15+('i'&31)<<10,
{DBLS} 16_53C8<<16+ reg<<6+longrel,
'd'<<25+('b'&31)<<20+('l'&31)<<15+('s'&31)<<10,
{DBCC} 16_54C8<<16+ reg<<6+longrel,
'd'<<25+('b'&31)<<20+('c'&31)<<15+('c'&31)<<10,
{DBCS} 16_55C8<<16+ reg<<6+longrel,
'd'<<25+('b'&31)<<20+('c'&31)<<15+('s'&31)<<10,
{DBNE} 16_56C8<<16+ reg<<6+longrel,
'd'<<25+('b'&31)<<20+('n'&31)<<15+('e'&31)<<10,
{DBEQ} 16_57C8<<16+ reg<<6+longrel,
'd'<<25+('b'&31)<<20+('e'&31)<<15+('q'&31)<<10,
{DBVC} 16_58C8<<16+ reg<<6+longrel,
'd'<<25+('b'&31)<<20+('v'&31)<<15+('c'&31)<<10,
{DBVS} 16_59C8<<16+ reg<<6+longrel,
'd'<<25+('b'&31)<<20+('v'&31)<<15+('s'&31)<<10,
{DBPL} 16_5AC8<<16+ reg<<6+longrel,
'd'<<25+('b'&31)<<20+('p'&31)<<15+('l'&31)<<10,
{DBMI} 16_5BC8<<16+ reg<<6+longrel,
'd'<<25+('b'&31)<<20+('m'&31)<<15+('i'&31)<<10,
{DBGE} 16_5CC8<<16+ reg<<6+longrel,
'd'<<25+('b'&31)<<20+('g'&31)<<15+('e'&31)<<10,
{DBLT} 16_5DC8<<16+ reg<<6+longrel,
'd'<<25+('b'&31)<<20+('l'&31)<<15+('t'&31)<<10,
{DBGT} 16_5EC8<<16+ reg<<6+longrel,
'd'<<25+('b'&31)<<20+('g'&31)<<15+('t'&31)<<10,
{DBLE} 16_5FC8<<16+ reg<<6+longrel,
'd'<<25+('b'&31)<<20+('l'&31)<<15+('e'&31)<<10,
{BCHG} 16_0140<<16+ ireg9<<6+rwea,
'b'<<25+('c'&31)<<20+('h'&31)<<15+('g'&31)<<10,
{BCLR} 16_0180<<16+ ireg9<<6+wea,
'b'<<25+('c'&31)<<20+('l'&31)<<15+('r'&31)<<10,
{BSET} 16_01C0<<16+ ireg9<<6+wea,
'b'<<25+('s'&31)<<20+('e'&31)<<15+('t'&31)<<10,
{BTST} 16_0100<<16+ ireg9<<6+ea,
'b'<<25+('t'&31)<<20+('s'&31)<<15+('t'&31)<<10,
{MOVEM} 16_4880<<16+ multiple,
'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+ ea<<6,
'm'<<25+('t'&31)<<20+('c'&31)<<15+('c'&31)<<10+('r'&31)<<5,
{MTSR} 16_46C0<<16+ ea<<6,
'm'<<25+('t'&31)<<20+('s'&31)<<15+('r'&31)<<10,
{MFSR} 16_40C0<<16+ wea,
'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
{?}routine PUT OPCODE(integer op)
{?} put mnemonic(def(op+op))
{?}end
routine STORE(integer v,f)
!$IF VAX
{ v = v&16_FFFF; v = v!sign16 %if v&sign16 # 0
!$FINISH
prog(pc) <- v; pflag(pc) = f; pc = pc+1
end
routine MAKE ROOM(integer size)
integer newbase,newlim
size = (size+127)&(¬127)
ownbase = ownbase-size
croak("Program too big") if ownbase <= cad
newbase = ownbase; newlim = newbase+ownad
cycle
final(newbase) = final(newbase+size)
newbase = newbase+1
repeat until newbase >= newlim
end
routine FILL CODE(integer n)
integer i
i = cad; cad = cad+n
while n > 0 cycle
final(i) = 16_80; i = i+1; n = n-1
repeat
end
routine FILL OWN(integer n)
integer i
make room(n)
i = ownbase+ownad; ownad = ownad+n
while n > 0 cycle
final(i) = 16_80; i = i+1; n = n-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 SET OWN WORD(integer v)
make room(2) if ownbase+ownad > finalbound
!$IF VAX
{ final(ownbase+ownad) <- v>>8; final(ownbase+ownad+1) <- v
!$IF APM
shortinteger(final0+ownbase+ownad) <- v
!$FINISH
ownad = ownad+2
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
record (identinfo)name DX,DY
switch S(0:21)
constbytearray SIZESYM(0:3) = 'L','B','W','?'
integer fn NONLOCAL(integer l)
integer r
result = mb if l = outerlevel
hold(l)_status = hold(l)_status!globbed if l # level
result = f1 if l = outerlevel+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 ; !D
op = moveq if y <= 0 and y >= litmite and size&3 = 0
else if modex&2_110000 = 0; !A
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 c
then op=op+(addi-add) {ADDI,SUBI,CMPI}
else if op <= eor
op = op+(addi-add) if y <= 0 {ANDI,ORI,EORI}
finish
info = def(op+op-1)
opcode = info>>16
if info&sized # 0 start ; !data size required
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; !areg size required
fault(sizerr) if size = 1
if op # movem start
if size = 0 start
size = 4 unless y <= 0 and is short(litval(y))
finish
if size = 4 start
if op = movea then opcode = opcode!!16_1000 c
else opcode = opcode+16_0100
finish
else ; !MOVEM
size = 4 if size = 0
opcode = opcode+16_0040 if size = 4
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(',') if info&63 # 0
{?} 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 >= swpc-8
kind = info>>6
again:
->s(kind&31)
s(0):
next:
kind = info
if kind # 0 start
dy == dx; y = x; mode = modex
info = 0
->again
finish
!
!$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
else if dy_mode # pcmode
fault(moperr)
finish
end
s(qea): !LEA
-> ea0 unless mode&63 = x-(a0-indexmode) and dy_val&255 = 0
! LEA 0(Ax,Dy) => ADDA Dy,Ax
opcode = 16_D1C0+dy_val>>12&15
-> next
s(wea):
dy_flags = dy_flags!(mflag!wflag)
-> wea1
s(rwea): ![for our purposes, read&write counts as neither]
dy_flags = dy_flags!mflag
wea1:
-> err if y <= 0 or mode&63 >= pcmode
-> ea1
s(revea): !reversible cases (EA,REG or REG,EA)
if modex&2_111000 # 0 start ; !dest not D
kind = shift; info = rwea
opcode = opcode!!16_0100
->sreg
finish
s(ea): 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
fill own(1) if ownad&1 # 0
dy_val = ownad
set own word(16_207C+(mb-a0)<<9); !MOVE.L #xxxxxxxx,MB
set own word(0); set own word(0)
set own word(16_4EF9); !JMP xxxxxxxx
set own word(0); set own word(0)
finish
if (op = lea or op = pea) and mode&63 # pcmode start
!taking address: might read or write
dy_flags = dy_flags!(mflag+rflag+wflag)
->err if mode&2_111000 < aregmode+indir
else
dy_flags = dy_flags!(mflag+rflag)
finish
ea1:
extword = dy_val
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+(aregmode+indir-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(exreg&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(qpre):
-> 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(reg): sreg:
-> err unless mode&2_111000 = 0
mode = mode&7
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 -30 <= y and y&1 = 0; !{0<=}litval(y)<=15
s(mquick):
->err unless y <= 0 and 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 reg
->sreg if y > 0
opcode = opcode!!16_900
s(imm):
->err if y > 0
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):
-> err if y <= 0
-> err if mode # absmode
opcode = dy_val
->next
err:
fault(moperr)
->next
end ; !plant
routine PLANTLIT(integer op,v,x)
if v >= 0 start
if v > smallmax then litstore(litmax) = v and v = litmax c
else v = -(v<<1)
else
if v < smallmin then litstore(litmax) = v and v = litmax c
else v = v<<1+1
finish
plant(op,v,x)
end
routine PLANTLIT2(integer op,y,v)
if v >= 0 start
if v > smallmax then litstore(litmax) = v and v = litmax c
else v = -(v<<1)
else
if v < smallmin then litstore(litmax) = v and v = litmax c
else v = v<<1+1
finish
plant(op,y,v)
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 size # 1 and ad&1 # 0
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-d0b<<(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 # 0 start
r = free reg(anydreg)
plantlit(move,bytes-1,r)
pc1 = pc
plant(op,source,dest)
plantlit2(dbra,r,(pc1-pc-1)<<1)
bytes = undef
else
r = free reg(anydreg!bregb)
plantlit(move,bytes,r)
pc1 = pc
plant(op,source,dest)
plant(sub,one,r)
plantlit2(bne,0,(pc1-pc-1)<<1)
bytes = 0
finish
c_reg_content(r) = bytes; free = f
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
routine GET BOUNDS(integer t,integername lo,hi)
![Note: sets HI after LO -- see dummy params in VALOK]
record (identinfo)name tp==typecell(t)
if tp_type = t # inttype start ; !basetype
lo = 0; hi = tp_size
else
if tp[1]_mode # litmode then lo = minint c
else lo = tp[1]_val
if tp[2]_mode # litmode then hi = maxint c
else hi = tp[2]_val
finish
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
s = 4; s = size(tp_type) if tp_flags >= 0
get bounds(tp_xtype,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 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
integer fn TSIZE(integer t)
result = size(dict(t)_type)
end
routine FORGET(integer r)
c_reg_content(r) = undef
end
routine FORGET CC
c_reg_ccy = undef
end
routine FORGET REGS
shortname 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
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)
!<<IMP
!* PRIMGEN marker 3
const short array PRIMCODE(1:396) <-
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_B886,16_6C0E,16_4284,16_41FA,
16_FFE0,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_1811,16_9004,16_6504,16_9010,16_640C,16_41FA,16_FFE4,16_7203,
16_7051,16_4EF8,16_3EFA,16_1018,16_670C,16_D111,16_1398,16_4801,
16_5204,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_6D08,16_204F,16_91C0,
16_B1C6,16_6C0E,16_2400,16_41FA,16_FFD8,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_245F,16_9EC0,16_558F,16_224F,16_BFC8,16_6E0E,
16_1010,16_12D8,16_51C8,16_FFFC,16_204F,16_224F,16_4ED2,16_1018,
16_5289,16_D0C0,16_D2C0,16_1320,16_51C8,16_FFFC,16_204F,16_224F,
16_4ED2,16_4E75,
16_43EF,16_FF00,16_2448,16_D5C0,16_2049,16_9280,16_6C04,16_4211,
16_4E75,
16_1281,16_5219,16_12DA,16_51C9,16_FFFC,16_4E75,
16_700A,16_4EF8,16_3E70,16_4E75,
16_7020,16_4EF8,16_3E70,16_4E75
!<<BOTH
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==typecell(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
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 byte value ok
! + 2<<16 to indicate short value ok
! + STACK if stack ok [not yet: too complex]
constinteger ASL=32,
CMPM=43,
TRAPV=70,
SWAP=74, EXTL=76,
JMP=57, TST=59, DBNE=86
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
constinteger VAL=sign+anyreg, REF=sign,
SIZESHIFT=16,
TOBYTE=1<<16, TOSHORT=1<<17, {1<<18 not sig}
TOSTACK=1<<19, ASAD=1<<20
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)
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)
plant(move+s<<8,x,prea7)
if s < 4 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 = 999 if a >= imul; !funcall,mapcall
wy = weight(dp_y)
result = wy if wy >= 999
wy = wy-1 if a = recref and dict(dp_x)_flags >= 0
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
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?]
c_reg_content(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&(¬(d0b<<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,d0b<<r)
eval parlist(darg_link,q)
return
finish
eval parlist(darg_link,q)
return if stage = 0
finish
eval(v,d0b<<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 OK REG(integer got)
r = got
if d0b<<(got-d0)&rset = 0 start
c_reg_content(got) = pp
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
r = free reg(rset&(¬bregb)); plant(move,got,r)
c_reg_ccx = pp and c_reg_ccy = 0 if r < a0
finish
finish
end
routine OK AREG(integer got,ok)
r = got
if a0b<<(got-a0)&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
routine PARTREG
! Something smaller than integer has been loaded to R
! Determine what else to do (using SX,SY)
sy = 4 if r = breg or r >= a0
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,255,r)
else ; !unsigned word (half)
plantlit(and,16_FFFF,r)
finish
sy = 4
finish
repeat
end
!!Start of EVAL
stsize = stsiz; !additional parameter (for TOSTACK cases)
rset = rset&(¬anyareg) if rset&tobyte # 0; ![1 bit]
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)
oldfree = free; freed = 0
if rset # inst start
unless dp_mode&2_110000 = 0 and pp < np0 start ; !not already reg
j = pp
if rset&(anydreg!bregb{+tostack}) # 0 start ; !data reg acceptable
i = d0
cycle ; !See if available
j = i and exit if c_reg_content(i) = j
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
j = i and exit if c_reg_content(i) = j
i = i-1; i = maxdreg if i = a0-1
repeat until i < d0
else if j < explim and rset # tostack; !REF: try for address
i = a0
cycle
if c_reg_content(i) = j+ad start
free = free&(¬(a0b<<(i-a0)))
dp_flags = dp_flags!(rflag+wflag)
pp = i+indir
return
finish
i = i+1
repeat until i > maxareg
finish
else ; !already reg
j = dp_mode+d0; !in case reg alias
if rset < 0 start ; !EA ok means any reg ok
pp = j
return
finish
pp = c_reg_content(j); !fiddle for update
finish
if 0 < j <= a7 start ; !operand (now) in reg
ok reg(j)
dp_flags = dp_flags!rflag
-> endload
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
->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); plant(move,p,r)
finish
c_reg_ccx = pp and c_reg_ccy = 0 if r < a0
else
if i > 0 start
free = oldfree
r = maxareg+1
cycle
r = r-1
if r < a0 start
r = free areg(p+ad); plant(move,p,r)
plant(move,r+indir,r) if i = 3
check address(r) if i > 1 and control&assbit # 0
finish
repeat until c_reg_content(r) = p+ad
free = free&(¬(a0b<<(r-a0)))
p = r+indir
finish
pp = p and return if rset = ref
sx = rset>>sizeshift&3; sx = 4 if sx = 0
i = dp_flags
sy = size(dp_type)
if c_localdpos <= p < dictlim 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 = -sy if sy # 4 and (dict(dp_type)_flags&nonord # 0 c
or dict(dp_type+1)_val = 0); !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
if rset&(anydreg!bregb) = 0 start
!Can't load bytes,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&(¬anydreg); !prefer areg for word (auto-extend)
finish
r = free reg(rset)
plant(move+|sy|<<8,p,r)
c_reg_ccx = pp and c_reg_ccy = 0 if r < a0
if sy # 4 start
partreg
finish
if i >= 0 start
plant(cmp+i<<8,r,d7); !check unassigned
srcall(unass)
forget cc
finish
if sy # 4 and r # breg start ; !not full reg
forget(r)
-> endload1
finish
finish
endload:
c_reg_content(r) = pp
endload1:
free = free&(¬(d0b<<(r-d0)))
r = r+indir if rset = ref
pp = r
return
dataload:
eval(p,anydreg)
ok reg(p)
-> endload
!!!!!!!!!!!!!!!! Array / Record / Map !!!!!!!!!!!!!!!!!!
integer fn FREEISH AREG(integer for)
!Use the register component of M if alterable
! to avoid excessive dissipation of address registers
integer i
i = m&7
result = free areg(for) if a0b<<i&oldfree = 0 or m >= framemode
free = free&(¬(a0b<<i))
i = i+a0; c_reg_content(i) = for
result = i
end
routine ADEVAL(integer x,y,q)
!Base X, scaled index Y, displacement Q
integer i,j
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 = aregmode+indir
m = m+(dispmode-(aregmode+indir))
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
i = freeish areg(x+ad)
plant(lea,x,i)
m = i+(dispmode-a0); v = 0
finish
if y # 0 start
if m&63 = pcmode start
i = free areg(undef); plant(lea,temp(m,v+q),i)
m = i+(dispmode-a0); v = 0; q = 0
else if not is mite(v+q); !indexmode out
if not is mite(q) start ; !& out even if V absorbed
i = freeish areg(undef)
if is short(v+q) start
plant(lea,temp(m,v+q),i)
else
plant(lea,x,i); addimm(q,i)
finish
q = 0
else
i = freeish areg(x+ad)
plant(lea,x,i)
finish
m = i+(dispmode-a0); v = 0
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 bounds(tx_xtype,sx,sy)
!establish multiplier (element size)
m = |nsize(tx)|
!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&free+asad)
plant(add,d0,i)
if dp_flags < 0 then forget(i) {ad of ad of P} c
else c_reg_content(i) = p+ad
free = free!d0b if freed = 0
restore(freed)
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
if m&(m-1) # 0 and m <= 32767 and sy <= 32767 and sx >= -32768 start
putexp(muls,y,litref(m),inttype)
else
putexp(imul,y,litref(m),inttype)
finish
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
ok reg(m+(a0-dispmode))
free = oldfree
-> endload
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)
free = free&(¬(a0b<<(r-a0)))
c_reg_content(r) = p+ad
m = r+(dispmode-a0); v = 0; !0(A?)
->setmode
funcall:
commandeer(c_free)
call
r = typecell(dx_type)_reg&15+d0
c_reg_ccx = pp and c_reg_ccy = 0 if dx_flags&okflag # 0
endloadr:
free = oldfree
if rset # ref then ok reg(r)
restore(freed)
->endload
rcall:
flush if pendcond # 0
update sp
!<<IMP
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
!<<BOTH
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
rset = rset&(¬bregb)
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
!<<IMP
do(prel):
! P => {prel,BASENAME,INDEX}
dx == dict(x)
m = |size(dx_type)|
sx = 0; sy = 999999
-> index1
!<<BOTH
do(check): !CHECK rangetype,value
commandeer(d0b)
eval(y,d0b)
srcall(x)
r = d0
-> endloadr
![Note that all literal subtraction comes through as ADD]
do(add):
if control&overbit # 0 start
-> dataload if rset&(¬anyareg) = 0
rset = rset&(¬anyareg)
finish
-> dataload if rset&(¬bregb) = 0
rset = rset&(¬bregb)
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)
->fin1
finish
if y = -(128<<1) start ; !+128
act = sub; y = y+1; !- -128 (MOVEQ)
-> op2
finish
finish
-> op1
do(eor):
-> dataload if rset&(¬bregb) = 0
rset = rset&(¬bregb)
do(or):
do(and):
-> dataload if rset&(¬anyareg) = 0
rset = rset&(¬anyareg)
op1:
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
-> op2
do(sub):
if control&overbit # 0 start
-> dataload if rset&(¬anyareg) = 0
rset = rset&(¬anyareg)
finish
rset = rset&(¬bregb)
op2:
eval(x,rset&free)
op3:
oldfree = free
if y <= 0 and y >= litmite and free&(anydreg!bregb) # 0 start
eval(y,anydreg!bregb); !bring Y to reg
else if act = eor and y > 0
eval(y,anydreg)
else if act > sub
if x = breg and y > 0 start
sy = tsize(y)
if sy = 1 or (sy = 2 and act = and) start
eval(y,val&(¬anyareg)+sy<<sizeshift)
act = act+sy<<8 if y > d7
finish else eval(y,val&(¬anyareg))
finish else eval(y,val&(¬anyareg))
else
eval(y,val)
finish
free = oldfree
fin1:
plant(act,y,x)
-> fin3 if act > sub
fin2:
plant(trapv,0,0) if control&overbit # 0
fin3:
pp = x; c_reg_content(x) = p
if act <= opmax then c_reg_ccx = p and c_reg_ccy = 0 c
else forget cc
return
do(muls): do(mulu):
-> dataload if rset&(¬(anyareg!bregb)) = 0
rset = rset&(¬(anyareg!bregb))
eval(x,rset&free)
oldfree = free
eval(y,anydreg) if y > 0; ![could do better for short]
free = oldfree
plant(act,y,x)
-> fin2
do(lsl): do(lsr):
-> dataload if rset&(¬(anyareg!bregb)) = 0
rset = rset&(¬(anyareg!bregb))
eval(x,rset&free)
if y < 0 and y >= litquick start
act = act!!(lsl!!lsr) and y = y-1 if y&1 # 0; !negate if neg
else
oldfree = free; eval(y,anydreg); free = oldfree
finish
->fin1
do(neg):
if y # 0 start
r = y; y = x; x = r
act = sub
-> do(sub)
finish
do(not):
-> dataload if rset&(¬(anyareg!bregb)) = 0
rset = rset&(¬(anyareg!bregb))
eval(x,rset&free)
plant(act,0,x)
-> fin3
do(iabs):
-> dataload if rset&(¬(anyareg!bregb)) = 0
rset = rset&(¬(anyareg!bregb))
x = y
eval(x,rset&free)
plant(move,x,x) if c_reg_ccx # y or c_reg_ccy # 0
plantlit2(bge,0,2)
plant(neg,0,x)
->fin2
do(fabs):
-> dataload if rset&(¬(anyareg!bregb)) = 0
rset = rset&(¬(anyareg!bregb))
x = y
eval(x,rset&free)
plantlit(and,16_7FFFFFFF,x)
->fin3
routine DO SHIFT
integer 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)
if i < litquick start
oldfree = free; eval(i,anydreg); free = oldfree
finish
plant(asl,i,x)
finish
end
do(imul):
-> dataload if rset&(¬(anyareg!bregb)) = 0
rset = rset&(¬(anyareg!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)
do shift if j&1 = 0
if j # 1 start
plant(move,x,prea7)
do shift
plant(add,posta7,x)
finish
->fin2
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&(¬(anyareg!bregb)) = 0
rset = rset&(¬(anyareg!bregb))
eval(x,rset&free)
oldfree = free
eval(y,anydreg)
free = oldfree
if act = drem then plant(divs,y,x) and plant(swap,0,x) c
else plant(act,y,x)
plant(extl,0,x)
-> fin3
finish
evalxy
srcall(idiv)
putexp(act!!(idiv!!drem),xx,yy,inttype)
if act = idiv start
c_reg_content(d1) = item; r = d0
else
c_reg_content(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+bregb+a0b+a1b+a2b)
fault(plexerr) if free&(a0b+a1b+a2b+d0b+bregb) # a0b+a1b+a2b+d0b+bregb
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
if y >= explim or y <= 0 then sy = 4 else sy = tsize(y)
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 ; ![???unsigned???]
if y # 0 start ; !not comparison with zero
wx = weight(x); wy = weight(y)
condswop if wx < 999 and wy > wx+1
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
if y >= litmite start
eval(x,val+sx<<sizeshift)
if (sx = 4 and free&anydreg # 0) -
or (x > a7 and dict(x)_mode&63 = pcmode) start
eval(y,anydreg)
condswop and sx = sy unless x <= d7
finish
else
sx = 0 if sx = 1; ![to ensure comparison fails?]
eval(x,val+sx<<sizeshift)
sx = 2 if a0 <= x <= a7 and is short(litval(y))
finish
plant(cmp+sx<<8,y,x)
unsigned if sx = 1
c_reg_ccx = xx; c_reg_ccy = yy
else ; !Y not literal
condswop if sy < sx
eval(x,anyreg)
if sy <= 2 and sy = sx and (sy=1 or x < a0) start
eval(y,val+sy<<sizeshift)
plant(cmp+sy<<8,y,x)
unsigned if sy = 1
forget cc
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 and control&strassbit = 0) -
or stringy # tx_flags&cat # sety start
!equals,notequals or rec,array
! [No routine call required to implement]
if wy >= 999 start ; !both complex
eval(x,tostack); free = free!a0b
eval(y,anyareg&free+asad)
x = freeareg(undef)
plant(move,a7,x)
else
eval(x,anyareg&free+asad)
forget(x)
eval(y,anyareg&free+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
! [Routine call required: must bring complex to stack]
if wx >= 999 start
eval(x,tostack); free = free!a0b
if wy >= 999 start
stsiz = sy; stsiz = -stsiz if tx_flags&cat # stringy
eval(y,tostack)
y = a1; plant(move,a7,y)
sy = (|sy|+1)&(¬1); sy = 256 if sy = 0
x = a0; plant(lea,tempd(a7,sy),x)
else
eval(y,a1b+asad)
x = a0; plant(move,a7,x)
finish
else
eval(x,a0b+asad); eval(y,a1b+asad)
finish
!<<IMP
srcall(scomp)
unsigned
!<<BOTH
finish
forget cc
finish
else ; !comparison with zero
if sx <= 0 or (sx = 1 and dx_mode >= dispmode) 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&free+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
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
!<<IMP
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
!<<BOTH
!!!!!!!!!!!!!!!!!!!!!!!! Assignment !!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
predicate EASY(integer y)
! Determine if structure assignment (string, set)
! 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,tobyte+val); !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
false if p <= undef; !literal, basereg or undef
true if p = dest or p = d {%or d >= np0
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
forget(dest) and return if dest <= a7
d = dest; d = d-ad if d >= explim
for r = d0,1,maxareg cycle
forget(r) if unsafe(c_reg_content(r))
repeat
forget cc if unsafe(c_reg_ccx) or unsafe(c_reg_ccy)
end
predicate XFREE(integer v,strong)
record (identinfo)name dp
cycle
v = v-ad if v >= explim
exit if v < dictlim
dp == dict(v)
false if not xfree(dp_y,1)
strong = 1 if dp_y >= dictlim
v = dp_x
repeat
true if v # x or strong = 0
false
end
!<<IMP
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)
!<<BOTH
do(jamass):
do(assign):
do(okass):
flush if pendcond # 0
if xx >= 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,tobyte+val); !character value
eval(x,anyareg&free+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,sx)
else if act # assign or sx = -256 or control&capbit = 0
! No check needed
if wx > 1 then eval(x,anyareg&free+asad) and eval(y,anyareg&free+asad) c
else eval(y,anyareg&free+asad) and eval(x,anyareg&free+asad)
!not worth %if act # jamass %and sx >= -4 %start
! %cycle
! plant(moveb,y+post,x+post)
! sx = sx+1
! %repeat %until sx >= 0
! %else
i = free reg(anydreg!bregb)
if act = jamass 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)
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&free+asad)
forget(y)
y = y+post
eval(x,anyareg&free+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_val = sp and dx_mode = c_mode start
if sx = 4 or x >= explim then c_val = c_val-4 c
else c_val = c_val-2
finish
update sp
finish
op = move
case = val; case = case+sx<<sizeshift if sx # 4
if x <= a7 start ; !explicit assignment to reg
if xfree(y,0) start
case = 1<<(x-d0); free = free!case
else
free = free&(¬(1<<(x-d0)))
finish
finish
if sx # 4 and act = assign and control&capbit # 0 start
eval(y,d0b)
srcall(dx_type); !range check
finish
i = y; i = i-ad if i >= explim
if i >= np0 start ; !SOURCE complex
if dx_flags&okflag # 0 or control&bassbit>>1<<sx = 0 start
dy == dict(i)
if y >= 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
act = add
-> tostore
finish
else
if dy_x = x c
and (dy_act < neg or (dy_act = neg and dy_y = 0)) start
act = dy_act; y = dy_y
-> tostore
finish
finish
finish
if wx < 999 then eval(y,case) and eval(x,ref) c
else eval(x,ref) and eval(y,case)
else
eval(x,ref)
if y <= 0 start
if y = 0 and dx_flags&readable # 0 then op = clr c
else if y >= litmite and sx = 4 then eval(y,anydreg)
else
eval(y,case) unless y <= a7
finish
finish
if y # x start
if 0 < y <= maxareg and 0 < yy = c_reg_content(y) start
beware(xx)
c_reg_content(y) = xx
finish else beware(xx)
plant(op+(sx&3)<<8,y,x)
c_reg_ccx = xx; c_reg_ccy = 0
finish else beware(xx)
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)
act = add
tostore:
if y = 0 start ; ![only for NOT,NEG]
eval(x,ref)
else if y < 0
if act = add start ; ![+- literal]
if y >= litquick start ; !-8:-1 or 1:8
act = sub and y = y-1 if y&1 # 0; !negate if neg
eval(x,ref)
-> past
finish
act = sub and y = y+1 if y = -(128<<1); !128=>-128
finish
eval(x,ref)
eval(y,anydreg) if y >= litmite and anydreg&free # 0
else if x <= a7
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
->endass
!!!!!!!!!!!!!!!!!!!!!! Returns and jumps !!!!!!!!!!!!!!!!!!!!!!!!
!
do(return): !terminate procedure
update sp
if c_type # 0 start ; !function,map
r = typecell(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
if c_reg_content(r+d0) # y start
flush if pendcond # 0
eval(y,d0b<<r)
finish
c_status = c_status!wrongcc unless c_reg_ccx = i and c_reg_ccy = 0
else ; !struct fn or map
c_status = c_status!wrongcc
flush if pendcond # 0
y = y+ad if c_type > 0; !ie struct fn
sp = c_sp
eval(y,d0b<<r)
if c_sp # sp start
addimm(sp-c_sp,a7); c_sp = sp
finish
finish
finish
if c_temps # 0 start
flush if pendcond # 0
addimm(c_temps,a7)
finish
dict(dictlim)_val = c_return
compile uncond branch(dictlim)
c_return = -(pc-1)
return
do(jumpout):
update sp
flush if pendcond > 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
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
i = dx_val; !start of table
dy == typecell(dx_type)
get bounds(dy_xtype,sx,sy)
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 > outerlevel 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 start ; !passed in reg, not on stack
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)
else ; !structure by value
tp == typecell(darg_type)
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!diagbit!linebit) # 0 start
flush if pendcond > 0
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
continue if j = 0
k = -j
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 >= ownbase
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,a,b
record (identinfo)name dp,tp
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
!special code (11) for %routine ...(%string(255) parm)
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+byteinteger(a+1))
cycle
a = a+2; b = b-2
exit if b < 0
k = byteinteger(a)<<8
k = k+byteinteger(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&(diagbit!linebit!tracebit) # 0 c
and level > outerlevel 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 > outerlevel 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 > outerlevel start
c_dpid_flags = c_dpid_flags!okflag if c_type > 0 c
and c_status&wrongcc!c_reg_ccx!c_reg_ccy = 0
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 !!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!<<IMP
routine TOPRED
item = litref(value) if item = 0
putact(compare,item,0)
condop = bne!!polarity
item = np-1
end
!<<BOTH
!
routine RESET CONTEXT(integer pid,free)
starts = 0; cycles = 0
c = 0
forget all
c_localdpos = dlim; c_parlim = dlim; c_localtext = charlim
c_localpc = pc; c_localswpc = swpc; c_lab1 = curlab
c_shorts = zeroshorts; c_free = free
c_mode = framemode+level; c_vintage = vintage
c_pid = pid; c_dpid == dict(c_pid)
end
routine OPEN BLOCK(integer pid)
forget regs; !a bit extreme, but don'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 == typecell(ap_type); btp == typecell(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 POP CONTEXT
pc = c_localpc; swpc = c_localswpc; curlab = c_lab1
dlim = c_parlim
! %for i = 0,1,255 %cycle
! hashindex(i) = dict(hashindex(i))_hlink %while hashindex(i) >= c_localdpos
! %repeat
if level > outerlevel start
charlim = c_localtext
ranges = dict(ranges)_hlink while ranges >= c_parlim
c_dpid_type = crunched(c_dpid_type)
level = level-1; c = hold(level)
control = control&editbit ! c_oldcontrol&(¬editbit)
finish
dictshown = dlim if dictshown > dlim
starts = 0; cycles = 0
end
routine FIXUP SWITCH VECTOR(integer pos,record (identinfo)name dp)
integer x,y,j,default,temp,lo,hi
record (identinfo)name tp==typecell(dp_type)
x = dp_val
default = dp_link; default = pc if default = 0
get bounds(tp_xtype,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 CLOSE BLOCK
integer miss,under,pos,base
record (identinfo)name dp
! WRONGCC is clear if all %result statements leave correct CC
if c_type > 0 and c_status&wrongcc = 0 start
! set special values and see if they survive exit sequence
c_reg_ccx = 0; c_reg_ccy = 0
finish
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
typecell(c_dpid_type)_val = c_totstack
{?} if control&maplist # 0 start
{?} put ident(c_pid,0)
{?} 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
!Check identifier usage
miss = 0; under = 0
base = c_localdpos; base = 0 if level = outerlevel
pos = dlim; dp == dict(pos)
while pos > base cycle
pos = pos-1; dp == dp[-1]
if dp_flags&ext = 0 start
!<<IMP
!<<BOTH
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
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 = outerlevel; !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(idmissing,miss,0) if miss # 0
if under # 0 and c_faults = 0 start
put ident(under,1)
put string(" underused")
print line
finish
pop context
set first entry if firstpos >= dlim
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 = outerlevel 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
!<<IMP
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!! 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},
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
{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
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,257,297,309,319,327,1,1,1
CONSTBYTEINTEGERARRAY SYMBOL(1:340) = 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,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:340) = 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,11,0,0,0,0,0,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('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
!<<BOTH
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
!<<IMP
routine ALLOW(integer k)
if a(k) start
finish
end
routine GET LITSTRING
integer holditem
!Must be quoted string (for %alias and %include)
holditem = item; !preserve
get(const)
error(typerr+point) unless type = stringtype
cad = value; !reset
item = holditem; !restore
end
!<<BOTH
integer fn IDTEXT(integer f)
integer k
result = ditem_text if item > 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
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(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
!<<IMP
if item < inclim and ditem_flags&(rflag+wflag) = 0 c
then fault(duperr+warn+point) else fault(duperr+point)
!<<BOTH
finish
ok: dp_hlink = head; head = dlim; !insert in list
dp_text = idtext(d_flags)
finish else dp_hlink = 0 and dp_text = 0
item = dlim; ditem == dp
ditem_details = d
dlim = dlim+1
if dlim >= 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
!
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
predicate OK(integer l,u)
true if (l <= lower and upper <= u) {signed} c
or (0 <= lower and upper <= u-l) {unsigned}
false
end
s = 4
if ok(-32768,32767) start
s = 2; s = 1 if ok(-128,127)
finish
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 == typecell(wanted); tp == typecell(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)
if wp[1]_mode # litmode then get bounds(wp[1]_type,lo,hi) c
else lo = wp[1]_val
if wp[2]_mode # litmode then get bounds(wp[2]_type,hi,hi) c
else hi = wp[2]_val
if item = 0 start ; !literal
true if lo <= value <= hi
jammy = jammy!!1
else
jammy = jammy!!1 and true if tp_type = t
if tp[1]_mode # litmode then get bounds(tp[1]_type,l,h) c
else l = tp[1]_val
if tp[2]_mode # litmode then get bounds(tp[2]_type,h,h) c
else h = tp[2]_val
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
!<<IMP
else if wc&cat = arry
true if wp_type = tp_type and valok(wp_xtype,tp_xtype)
!<<BOTH
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 ; !null string
final(cad) = 1; final(cad+1) = value
value = cad; cad = cad+2
type = stringtype
finish else putexp(dtostring,normitem,0,string1)
true
!<<IMP
! sets again
!<<BOTH
finish
finish
false
end
!
routine GET VALUE(integer valtype)
get EXPRESSION(major,valtype)
end ; !GET VALUE
!
routine GET LITERAL(integer t)
literal = literal+1
get EXPRESSION(major,t)
literal = literal-1
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
end
routine GET REGSET
integer hold,set=0
cycle
get mident(d0,a7)
hold = item
get mident(hold,a7) if a(minus)
cycle
set = set!1<<(hold-d0)
hold = hold+1
repeat until hold > item
repeat until not a(slash)
item = 0; value = set
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 t,dummy,record (identinfo)name dp)
!Get Mcode operand
constinteger HASHSIGN=noteq
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
dp_flags = ditem_flags
dp_mode = ditem_mode; dp_val = ditem_val
while a(recsub) cycle
dformat == typecell(ditem_type)
syntax error unless dformat_flags&cat = recy c
and ditem_flags&(name+indirect) = 0
subbed = 1; get(ident); subbed = 0
error(namerr+point) if item <= 0
dp_flags = ditem_flags; dp_type = ditem_type
dp_val = dp_val+ditem_val
item = dummy; ditem == dp
repeat
return
finish
if op&255 = movem and item > 0 start
matched = 0
get regset
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)
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 = (item-d0)<<12+holdval&255
holdval = holdval+16_0800 if opsize(0) # 2
finish
get(right)
else
syntax error if hold < 0
m = absmode
finish
dp_mode = m; dp_val = holdval
item = dummy
end
constinteger temp=((('t'&31)<<5+('e'&31))<<5+('m'&31))<<5+('p'&31)
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
if x = temp start ; !*TEMP ...
value = 0
matched = 0 and get regset if a(ident)
c_free = value
return
finish
x = x<<5 until x&(31<<25) # 0
x = x!16_C0000000
find op(x,op,types)
op = op+opsize('B')<<8 if types&(sized!asized) # 0
x = 0; y = 0
if types>>6&63 # 0 start
get MOP(types>>6&63,lablim,dtemp)
x = normitem
get(comma) if types&63 # 0
finish
if types&63 # 0 start
get MOP(types&63,lablim+1,dtemp2)
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 == typecell(wanted); tp == typecell(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 tp_size = 0 or wp_size = 0
!<<IMP
!<<BOTH
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
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 reftype)
get EXPRESSION(simple,reftype!sign16)
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 dp
if hp_flags&alt = 0 start ; !no alternative
expfault(typerr)
true
finish
headitem = hp_hlink
cycle
report(internerr,0,6) and signal fail if headitem <= 0
dp == dict(headitem)
exit if string(dp_text+char0) = string(hp_text+char0)
headitem = dp_hlink
repeat
pact = headitem; hp == dp
arg = hp_type; darg == dict(arg); restype = darg_type
arg = darg_link; darg == dict(arg)
false
end
routine PUT BOUNDS(integer ft,at)
! FT is TYPE of formal, AT of actual array
integer maxarg=arg
record (identinfo)name ftp,atp,fxp,axp
cycle
ftp == typecell(ft); atp == typecell(at)
! %if ftp_flags&indirect # 0 %start; !complete dope vector
! ![now only for %string(*)%array%name]
! intern(11) %unless ftp_type = stringstar
! item = at
! put actual
! maxarg = ft %if ft > maxarg
! %exit
! %finish
if ftp_flags&cat = stringy start
exit if ftp_size # 0
if atp_size # 0 then item = litref(|atp_size|) -
else item = at-1
put actual
maxarg = ft-1 if ft-1 > maxarg
exit
finish
if ftp_xtype >= arg start ; !index type
fxp == typecell(ftp_xtype); axp == typecell(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; !element types
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 REFERENCE(0)
value = item-ad; !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
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 {OK if param?}
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
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
put actual
tp == typecell(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 non-literal dope vector
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
!<<IMP
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 REFERENCE(stringstar)
fore = item; 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)
item = 0
if a(dot) start
get REFERENCE(stringstar)
fault(rangerr+warn) if s < size(type) # 0
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)
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 else jammy = 0
matched = 1
finish
true
end
!<<BOTH
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
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
literal = literal+1
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
subbed = 1; dformat == fidp
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 VALUE(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
literal = literal-1
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<<inty, CHAROK=1<<chary,
BOOLOK=1<<booly, ENUMOK=1<<enumy,
REALOK=1<<realy, STRINGOK=1<<stringy,
ARROK=1<<arry, SETOK=1<<sety,
RECOK=1<<recy, POINTOK=1<<pointy,
NUMOK=intok!realok,
ORDOK=intok!charok!boolok!enumok,
RELOK=ordok!realok!stringok
routine CHECK1(integer ok)
cat1 = category(type)
if ok>>(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
!<<IMP
check1(relok)
get EXPRESSION(major,0)
c = category(type)
coerce(c) if c # cat1
if equals <= atom <= greater start ; ![ATOM always primed]
syntax error if double >= 0
double = item
else if double < 0
double = -2
finish
!<<BOTH
if item1 = 0 start
if item = 0 start
if size(type1) > 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
!<<IMP
integer fn OPVAL
! Returns result value for literal (ITEM=ITEM1=0)
! 0 for no-op (result is ITEM1,TYPE1)
! operator otherwise (result type is TYPE)
! NB literal INTY type is always INTTYPE (not subrange)
switch op(keyand:rshift)
-> 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
type = inttype
result = imul if control&halfbit = 0
result = muls
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; ![ATOM always primed]
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
!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
if ditem_flags&cat = recy and item > dnil start
get RECORD
return
else
item1 = item; ditem1 == ditem
if a(less) start ; !type coercion
get VALUE(0); get(greater)
type = item1
else
get(left); !store mapping
get VALUE(inttype)
get(right)
putexp2(storemap,item1,item1)
ditem_flags = writable!readable
ditem_mode = dispmode
finish
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)
if item = daddr start
get REFERENCE(0)
type = inttype
else
item1 = item
get REFERENCE(0)
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
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
if atom = aleft start ; !array subscript
cycle
item1 = item; ditem1 == ditem
tp == typecell(type)
if tp_flags&cat = stringy start
matched = 1
nonstandard(2)
get VALUE(bytetype)
putexp2(sindex,item1,chartype)
else
-> out unless tp_flags&cat = arry
matched = 1
get VALUE(tp_xtype); !get index
putexp2(index,item1,tp_type)
finish
ditem_flags = ditem1_flags&heritable
ditem_mode = ditem1_mode
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 == typecell(ditem_type)
syntax error unless dformat_flags&cat = recy
matched = 1
subbed = 1; get(ident); subbed = 0
error(namerr+point) if item <= 0
val1 = ditem1_flags&heritable!ditem_flags
putexp2(recref,item1,ditem_type)
ditem_flags = val1
ditem_mode = ditem1_mode
else if atom = atsign
nonstandard(4)
syntax error if ditem_flags&typeid = 0
matched = 1
ditem1 == ditem; item1 = item
get EXPRESSION(vsimple,inttype)
putexp2(storemap,item1,item1)
ditem_flags = writable!readable
ditem_mode = dispmode
else ; !pointer relative
error(nonref+point) if ditem_mode < dispmode
fault(sizerr) if size(ditem_type) = 0
matched = 1
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 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
out:
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+1; !enforce all literal
op = op&opval
literal = literal-1
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
atomp=expp and error(nonliteral+point) if literal # 0 and item # 0
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 (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 == typecell(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(typecell(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 == typecell(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,lo,hi
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 == typecell(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
get bounds(tp_xtype,lo,hi)
i = value-lo+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
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
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)
initial(star):
fault(lowlevel+warn+point) and control = control!lowbit if control&lowbit = 0
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 kattrib <= 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 = typecell(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
size = -4 if ditem_flags&(name+indirect) # 0
if depth # 0 start
dlink_link = item; dlink == ditem
if size > 0 start
!simple value
if dreg > maxcalldreg start
assign stack address
return
finish
c_reg_content(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 in AREG}
return
finish
c_reg_content(areg) = item+ad if speccing = 0 and ditem_flags < 0
ditem_reg = areg-d0; areg = areg+1
finish
finish
size = |size|
align(disp,size)
ditem_val = disp
if constmode # ditem_mode # ownmode start
disp = disp+size
if ditem_mode >= framemode start
align(disp,2)
ditem_val = c_sp-disp; !neg stack disp.
finish
finish
end
!
routine GET QIDENT
get(ident)
if mode = 0 start ; !within record format
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
finish
declare(decl)
end
!<<BOTH
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 >= ownbase
else
if ownbase+ownad+kk-finalbound > 0 start
make room(ownbase+ownad+kk-finalbound)
finish
i = ownbase+ownad; ownad = ownad+kk
finish
if itemsize <= 0 start
while n > 0 cycle
n = n-1; j = i+k
if v # 0 start
vv = v
cycle
final(i) = final(vv)
i = i+1; vv = vv+1
repeat until i =j
else
final(i) = 0 and i = i+1 while i < j
finish
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
!<<IMP
routine GET VAR BOUND
integer f
f = decl_flags
get DATA TYPE
decl_flags = okflag+mflag; decl_type = itemtype
get(ident); declare(decl)
decl_flags = f
assign address(itemsize)
end
routine DECLARE BOUND(integer mode,val)
declare anon(details(okflag,inttype,mode,val))
if depth # 0 and mode >= 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,tot,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 STRING STAR ARRAY
fault(notin+point) if depth = 0
! VAR for size
declare anon(details(okflag+mflag+inty,inttype,mode,0))
tot = item
assign address(4)
! TYPEID for string(*)
declare anon(details(typeid+stringy,inttype,0,0))
atype_type = item
elements = maxint
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
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
string star array if atype_type = stringstar
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
tot = litref(totsize) if tot = 0
putact(asize,item,tot)
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
tot = 0; 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
string star array if atype_type = stringstar
atype_xtype = i
declare anon(atype); !array type
if speccing = 0 start
tot = litref(totsize) if tot = 0
putact(asize,item,tot)
putact(0,i+1,i+2)
finish
tot = 0; 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 ; !element %name
atype_flags = atype_flags+name; atype_type = atype_type-name
finish
atype_mode = constmode; !by default (literal bounds)
tot = 0; 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 # constmode and mode # ownmode start
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
!** to be corrected **
!name already allocated
{ dp_val = disp; disp = disp+totsize}
dp_val = disp
if decl_flags < 0 then disp = disp+4 else disp = disp+totsize
finish
pos = pos+1
repeat
else ; !const,own
if decl_flags&(name+indirect) # 0 start
if mode = constmode then fill code(4) else fill own(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
dump const(0,elements) if elements > 0
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 == typecell(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 depth # 0 start ; !procedure as param
decl_flags = decl_flags!proc2; ![must push MB in case external]
else if mode >= framemode
decl_mode = procmode; decl_val = 0
decl_flags = decl_flags!proc1
decl_flags = decl_flags+spec if a(keyspec)
else if mode = ownmode; !external (not @)
decl_mode = procmode; decl_val = 0
if a(keyspec) start
decl_mode = ownmode; decl_flags = decl_flags+(spec+indirect)
finish
else ; !@...
decl_flags = decl_flags!proc1
decl_val = disp
stack = 4
finish
if 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
c_type = c_type!sign16 if decl_flags&writable # 0 {%map}
finish
dlim1 = dlim
declare anon(details(0,restype,0,stack))
! Result in A0 for %map or structure %fn
ditem_reg = 8 if decl_flags&writable # 0 {%map} -
or size(restype) <= 0 {structure %fn}
!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)
integer present=0
jammy = 0
if a assop(itemtype) start
get VALUE(itemtype)
dp_flags = dp_flags!okflag
present = 1
finish
if mode >= framemode start ; !dynamic
if present # 0 start
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
else if mode = constmode
syntax error if present = 0
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 ; !own
if present # 0 start
faultnum = rangerr+point+warn if faultnum = rangerr+point
dump const(value,1)
else
if itemtype < 0 then fill own(4) else fill own(|itemsize|)
finish
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
decl_flags = decl_flags!!(1<<subatom)
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; !%record(*)%array
adim = 0
! ITEMTYPE now reflects element type (+name)
! DECL is for the array itself
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
! %array%name versus %array
decl_flags = decl_flags+name if a(keyname)
finish
! %record(*) or %string(*) needs %name (or @)
! %string alone allowed only for %const%string
fault(illstarred) if itemsize = 0 c
and decl_flags >= 0 and disp ## jokerad c
and decl_type # stringtype {const}
if disp == c_val 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
else if decl_flags&ext # 0 and a(keyspec)
decl_flags = decl_flags!(spec+indirect)
finish
!Read identifier list
cycle
dlim0 = dlim
unless decl_type = arrstar start ; !not array
get QIDENT
assign address(itemsize)
if mode >= ownmode and depth = 0 start
if decl_flags&spec = 0 then get INITIAL VALUE(ditem) c
else set own word(0) and set own word(0)
finish
else
cycle
get QIDENT
assign address(0); !(4 if name)
exit if not a(comma)
atom = next atom
if atom # ident start ; !ie new type
if adim = 0 start ; !treat %array%name as %array(1)%name
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
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
initial(atsign):
dump = 0
atted:
fault(lowlevel+warn+point) and control = control!lowbit if control&lowbit = 0
get LITERAL(inttype)
jokerad = value
if a(left) start
get MIDENT(a0,a7)
get(right)
value = item+(dispmode-a0)
finish else value = absmode
literal = 1
get DECLARATION(dump!(okflag+writable+readable),value,jokerad,0)
-> term
initial(keyown):
literal = 1
get DECLARATION(writable+readable,ownmode,ownad,0)
-> term
initial(keyext):
fault(ordererr) if level # outerlevel
literal = 1
dump = subatom<<12
-> atted if a(atsign)
if a(left) start
get LITERAL(inttype); get(right)
maxcalldreg = (d0-1)+value&15
maxcallareg = (a0-1)+value>>4&15
dump = dump!!(value&(¬255))
finish
get DECLARATION(dump!(writable+readable),ownmode,ownad,0)
-> 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,c_mode,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
get bounds(item,lo,hi)
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&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(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)
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 # outerlevel
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
finish
end ; !GET STATEMENTS
!<<BOTH
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
constinteger INITSIZE=18
!%constinteger INITSIZE=30
integer i,reset,totsize,ownsize
! INIT SEQUENCE
! code to copy own values from end of code area to data area
!
! Program area Data area
! ________________ __________________
! | | | |
! | | | STACK SPACE |
! | CODE | | |
! | | SP->|~~~~~~~~~~~~~~~~|
! |______________| | |
! | init | | |
! |~~~~~~~~~~~~~~| |GLOBAL DYNAMICS |
! | | | |
! | OWN VALUES | MB->|~~~~~~~~~~~~~~~~|
! | | | |
! | | | OWNS |
! |______________| | |
! orig| |
! SP->|~~~~~~~~~~~~~~~~|
!
reset = 0; totsize = cad
ownsize = ownad
if ownsize # 0 start
fill own(4-ownad&3) if ownad&3 # 0
ownsize = ownad
reset = cad; !entry-point for RESET
totsize = totsize+(initsize+ownad); !total code size
finish
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
put word(ownsize>>16); !static data requirement
put word(ownsize)
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 ownsize # 0 start
put word(16_2248+mb-a0); ! move.l mb,a1
put word(16_41FA); ! lea initpatt,a0
put word(16_000E)
put word(16_303C); ! move.w #????,d0
put word(ownad>>1-1); ![individual owns in shortwords - 1]
put word(16_32D8); !l1 move.w (a0)+,(a1)+
put word(16_51C8); ! dbra d0,l1
put word(-4)
put word(16_4E75); ! rts
i = 0
cycle
print symbol(final(i+ownbase)); i = i+1
repeat until i = ownad
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]
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)
ownbase = finalbound-4095; ownad = 0
level = outerlevel; vintage = 1
pendout = 0; pendin = 0; polarity = 0
curlab = dictlim+1
reset context(procstar,defaultfree)
c_sp = -4; !allow for BSR
control = initcon
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
!<<IMP
get STATEMENTS(0)
!<<BOTH
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(ownad,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(ownad,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
!<<IMP
endofprogram