%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' !< |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 ! ! !<= 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 !< 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 !< 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 !<>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 !<= 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, (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) !<>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 %if dx_flags&(name+indirect) = 0 %or dx_flags&ext # 0 {temp} plant(jsr,0,x) %else %if free&a0b<<3 # 0 plant(move,x,a0+3) plant(jsr,0,a0+3+indir) forget(a0+3) %else plant(move,x,tempd(a7,-4)) plantlit(move,16_4EF9,tempd(a7,-6)) plant(jsr,0,lablim) %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,awkward %routine EVAL PARLIST(%integer arg,q) %record(identinfo)%name darg,dv %integer v,w,f,r,s !Stage 0 (forward): !Stage 0 (returning): !Stage 1 (forward): !Stage 1 (returning): %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_flags&proc # 0 %start s = 0 %if awkward # 0 %start f = v; f = f-ad %if f >= explim dv == dict(f) %if dv_flags&(ext+spec) # ext+spec %start !non-external to (maybe) external eval parlist(darg_link,q) %and %return %if stage # 0 %if dv_flags&(name+indirect) # 0 %then plant(move,f,prea7) - %else plant(pea,0,f) plantlit(move+2<<8,16_4EF9,prea7) {JMP entry} plant(move,mb,prea7) plantlit(move+2<<8,16_287C,prea7) {MOVE #xxxx,mb} extend stack(12) s = c_sp eval parlist(darg_link,q) %if darg_val > 0 %start plant(pea,0,temp(c_mode,s)) %else plant(lea,temp(c_mode,s),r+d0) free = free&(\(d0b< 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<= 999 %start eval parlist(darg_link,q) %return %if stage # 0 %else %if w >= 2 %and stage # 0 %start eval(v,d0b<>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<= 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<= framemode free = free&(\(a0b< {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 !<= 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 !<= 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 !< {prel,BASENAME,INDEX} dx == dict(x) m = |size(dx_type)| sx = 0; sy = 999999 -> index1 !< 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< 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< 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<= 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 !<= 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 !< endcomp !< 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 !<= 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<= explim %if i >= np0 %start; !SOURCE complex %if dx_flags&okflag # 0 %or control&bassbit>>1<= explim %start %if dy_act = prel %and dy_x = x-ad %c %and (dy_y < 0 %or dy_type = bytetype) %start y = dy_y y = litref(litval(y)*|size(dy_type)|) %if dy_type # bytetype 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< 0; !ie struct fn sp = c_sp eval(y,d0b< 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 !!!!!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !<= 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 !< 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<= 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 !<= 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 !< 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 !<= 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 !< 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 !<= 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 %if hp_flags&alt = 0 %start; !no alternative expfault(typerr) %true %finish item = hp_hlink %cycle report(internerr,0,6) %and %signal fail %if item <= 0 ditem == dict(item) %exit %if string(ditem_text+char0) = string(hp_text+char0) item = ditem_hlink %repeat headitem = item; pact = headitem; hp == ditem arg = hp_type; darg == dict(arg); restype = darg_type %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 !<= 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<>(cat1&cat)&1 = 0 %start %if cat1 = inty %and ok&realok # 0 %start toreal; cat1 = realy %else %if ok&stringok # 0 %and valok(stringtype,type) cat1 = stringy %else fault(typerr+point) %finish %finish type1 = type; item1 = item; val1 = value %end %integer%fn FROZEN LIT(%integer t,v) ! Used when the type of a literal will not be recoverable from context %integer hold,res hold = item putexp(move,0,litref(v),t); !NO-OP (distinctive Y) ditem_flags = okflag+wflag ditem_mode = constmode; ditem_val = v res = item; item = hold %result = res %end %routine COERCE(%integer c) %if c = inty %and cat1 = realy %start toreal %else %if cat1 = inty %and c = realy ![rather sloppy] %if item1 # 0 %start val1 = item; item = item1 toreal item1 = item; item = val1 %finish %else real(addr(val1)) = val1 type1 = realtype; cat1 = realy %else expfault(typerr) %finish %end %routine GET ARITH(%integer rank) get EXPRESSION(rank,0) rank = category(type) coerce(rank) %if rank # cat1 %end %integer%fn RCOND(%integer op) %constinteger EQUAL=2_1001000010, LESS =2_1010000001, GREATER=2_0101000001 %integer which,c !<= 0 double = item %else %if double < 0 double = -2 %finish !< 0 %or item1!val1 = 0 %or item!value = 0 %start !non-structure (compile-time) ![integer tests ok for real?] %if val1 < value %then which = less %c %else %if val1 = value %then which = equal %c %else which = greater %result = which>>(op-bne)&1 %finish item1 = frozen lit(type1,val1) %else swop op = op!!3 %if op&8 # 0; !no change for '=','#' %finish %finish %result = op %end; !RCOND !< op(atom) op(plus): check1(numok+setok) get ARITH(star) %if cat1 = inty %start %if item1 = 0 %start %result = val1+value %if item = 0 swop %finish %result = nop %if item!value = 0 type = inttype %result = add %else %if item1 = 0 %start %if item = 0 %start real(addr(val1)) = real(addr(val1))+real(addr(value)) %result = val1 %finish swop %finish %result = nop %if item!value = 0 %result = fadd %finish op(minus): check1(numok+setok) get ARITH(star) %if cat1 = inty %start %if item1 = 0 %start %result = val1-value %if item = 0 swop %and %result = neg %if val1 = 0 %finish type = inttype %if item = 0 %start %result = nop %if value = 0 value = -value %if value # minint %result = add %finish %result = sub %else %if item = 0 %start %if item1 = 0 %start real(addr(val1)) = real(addr(val1))-real(addr(value)) %result = val1 %finish %result = nop %if value = 0 %finish %result = fsub %finish op(exclam): check1(intok); get EXPRESSION(star,inttype) %if item1 = 0 %start %result = val1!value %if item = 0 swop %finish %result = nop %if item!value = 0 type = inttype %result = or op(exclam2): check1(intok); get EXPRESSION(star,inttype) %if item1 = 0 %start %result = val1!!value %if item = 0 swop %finish %result = nop %if item!value = 0 type = inttype %result = eor op(ampersand): check1(intok); get EXPRESSION(star2,inttype) %if item1 = 0 %start %result = val1&value %if item = 0 swop %finish item1 = 0 %and %result = 0 %if item!value = 0 type = inttype %result = and op(star): check1(numok+setok) get ARITH(star2) item1 = 0 %and %result = 0 %if item!value = 0 %if cat1 = inty %start %if item1 = 0 %start %result = val1*value %if item = 0 swop %finish 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 = 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< 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 !< 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 !<= 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 %finish %else; !@... decl_flags = decl_flags!proc1 decl_val = disp stack = 4 %finish %if decl_flags&ext # 0 %and a(keyalias) %start nonstandard(9) get(ident) %if item <= 0 %start fault(namerr+point) %else item = 0 %and decl_flags = decl_flags!alt %if dupok %finish %else get(ident) %finish declare(decl) headditem == ditem assign address(-6) %if depth # 0 argmode = c_mode&(\2_01000000)+1 %if decl_flags&spec # 0 %or decl_mode # procmode %start speccing = speccing+1 %else c_forward = c_forward-1 %if ditem_flags&rflag # 0 open block(item) c_type = restype 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<= 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 !<|~~~~~~~~~~~~~~~~| ! |______________| | | ! | 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 !<