Source: imp22g.i Object: imp22g.o Parms: MAP,PPRO,NOTRACE,NOLINE,LIST,NOARRAY,NODIAG,NOCHECK,MAXDICT,MAXWORK ERCC. Portable Imp80 Compiler Release 4 Version 13 Aug 96 4095 12285 1 %begin 2 3 %integerfn is short(%name v) 4 %result = 0 /* 0 false 1 true */ 5 %end 6 7 %integerfn is mite(%name v) 8 %result = 0 /* 0 false 1 true */ 9 %end 10 11 !!%external%string(255)%fn%spec cliparam 12 !!%external%integer%fn%spec cputime 13 14 %string(255)cliparam; cliparam = "adec" 15 16 !$IF ECSVAX 17 {%conststring(51) title = %c 18 {" EUCSD IMP Compiler for M68000. VAX Version 2.2g" 19 !$IF APM 20 %conststring(51) title = %c C " EUCSD IMP Compiler for M68000. APM Version 2.2g" 22 !$FINISH 23 ! 24 ! Hamish Dewar Computer Science Edinburgh University 1982/83/84 25 ! 26 %constinteger WHICH=M'.imp' 27 28 !< |flags|type| link| reg|mode|value|text|hlink| 140 ! D0 [@1] -> R | | | size| | | | | | 141 ! | | |xtype| | | | | | 142 ! D7 -> | | | | | | | | | 143 ! A0 -> E | | | | | | | | | 144 ! | | | | | | | | | 145 ! A7 -> G | | | | | | | | | 146 ! INDA0 -> | | | | | | | | | 147 ! S | | | | | | | | | 148 ! PREA7 -> | | | | | | | | | 149 ! I | | | | | | | | | 150 ! D | | | | | | | | | 151 ! E | | | | | | | | | 152 ! N | | | | | | | | | 153 ! T | | | | | | | | | 154 ! S | | | | | | | | | 155 ! |_____|____|_____|____|____|_____|____|____| 156 ! DICTLIM -> | -- |-- | -- | -- |mode|value| -- | -- | 157 ! C L | | | | | | | | | 158 ! O A | | | | | | | | | 159 ! M B | | | | | | | | | 160 ! P S | | | | | | | | | 161 ! |_____|____|_____|____|____|_____|____|____| 162 ! LABLIM -> |flags|type| act |----|mode|value|arg1|arg2| 163 ! C | | | | | | | | | 164 ! O | | | | | | | | | 165 ! M E | | | | | | | | | 166 ! P X | | | | | | | | | 167 ! L P | | | | | | | | | 168 ! E S | | | | | | | | | 169 ! X |_____|____|_____|____|____|_____|____|____| 170 ! EXPLIM -> 171 172 %constinteger SMALLMIN=-1024, SMALLMAX=1023, C LITMAX=smallmin-(smallmax+1), LITMIN=litmax-199, C LITMITE=-255, LITQUICK=-16, ONE=-(1<<1) 175 %constinteger D0=1, D1=d0+1, D2=d0+2, D7=d0+7, C A0=d0+8, A1=a0+1, A6=a0+6, A7=a0+7, C INDA0=a0+8, INDA7=inda0+7, C POSTA0=inda0+8, POSTA7=posta0+7, C PREA0=posta0+8, PREA7=prea0+7, C UNDEF=a7 181 %owninteger DICTLIM=1000, FINALBOUND=64 {see Init for adjustment} 182 %integer LABLIM,NP0,EXPLIM {continuing from DICTLIM} 183 %integer CHARBOUND {derived from DICTLIM} 184 %constinteger LABELS=42 {enough for Pascal reserveds}, C TRIPLES=200 186 %constinteger AD=16384 {any item + AD >= EXPLIM} 187 188 %constinteger BREG=D0+4, LINELOC=d0+5 189 %constinteger F1=a0+6, GB=a0+5, MB=a0+4; !level 1, global base, main base 190 %constinteger MAXDREG=d0+3, MAXAREG=a0+3 191 %constinteger D0B=1, D1B=2, D2B=4, BREGB=16, C A0B=16_100, A1B=16_200, A2B=16_400 193 %constinteger ANYDREG=16_00FF-bregb, ANYAREG=16_FF00, C ANYREG=16_FFFF 195 %constinteger DEFAULTFREE=2<<(maxdreg-d0)-1+(2<<(maxareg-a0)-1)<<8+bregb 196 %integer MAXCALLDREG, MAXCALLAREG 197 %integer FREE 198 199 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 200 !!!!!!!!!!!!!!!!!!!!!!! Big Literals !!!!!!!!!!!!!!!!!!!!!!! 201 %integer LITPOS 202 %integerarray LITSTORE(litmin:litmax) 203 ! 204 !!!!!!!!! Registers, Identifiers, Labels, Expressions !!!!!!!!! 205 ! 206 ! Operand attributes: 207 %recordformat OBJINFO %C C (%short FLAGS,TYPE, C (%short LINK %or %short XTYPE %or %short SIZE %or %short ACT), C %byte REG,MODE, C %integer VAL) 212 %recordformat IDENTINFO %C C ((%short FLAGS,TYPE, C (%short LINK %or %short XTYPE %or %short SIZE %or %short ACT), C %byte REG,MODE, C %integer VAL %or %record(objinfo) DETAILS), C (%short TEXT,HLINK %or %short X,Y)) 218 ! 219 !Machine addressing modes: 220 %constinteger AREGMODE=2_001000, C DISPMODE=2_101000, INDEXMODE=2_110000, ABSMODE=2_111000, C PCMODE=2_111010, LITMODE=2_111100 223 !Conversion factors for address register modes (from AREGMODE) 224 %constinteger INDIR=8, POST=16, PRE=24 225 !Additional source-related modes: 226 %constinteger LABMODE=2_10000000+pcmode, C PROCMODE=2_11000000+pcmode, C GLOBALMODE=dispmode+(gb-a0), C OWNMODE=2_01000000+dispmode+(mb-a0), C CONSTMODE=2_01000000+pcmode, C FRAMEMODE=2_10000000+dispmode 232 ! + 01000000 for dynamic array 233 ! 234 ! MODE,VAL: 235 ! %const simple : LITMODE the actual value 236 ! %const structure : CONSTMODE address in code area 237 ! variable etc : mode byte address/displacement 238 ! undefined label : LABMODE reference chain 239 ! undefined procedure : PROCMODE reference chain 240 ! record format : 0 size of record in bytes 241 ! 242 ! Significance of FLAGS: 243 %constinteger CAT =16_000F, {category: typeid only} C WRITABLE=16_0001, C READABLE=16_0002, {not write only} C VOLATILE=16_0004, C ARRFLAG =16_0008, {bound check needed} C ALT =16_0008, {alternative proc} C WFLAG =16_0010, {has been written to} C RFLAG =16_0020, {has been read from} C OKFLAG =16_0040, {no unassigned check needed, CC OK for fun} C NORET =16_0040, {routine does not return} C MFLAG =16_0080, {has had mem access} C SPEC =16_0100, {unbodied spec or forward label} C TYPEID =16_0200, {type identifier} C PACKED =16_0400, C INDIRECT=16_0800, C PROC =16_3000, {procedure not data} C PROC1 =16_1000, C PROC2 =16_2000, C EXT =16_4000, {external} C NAME =sign16 263 %constinteger HERITABLE=writable+readable+volatile %c C +wflag+rflag+okflag+arrflag 265 ! 266 !CATegories (type identifiers only): 267 %constinteger INTY=0, CHARY=1, BOOLY=2, ENUMY=3, C POINTY=4, REALY=5, C STRINGY=8, ARRY=9, SETY=10, C RECY=12, FILEY=13, C NONORD=12 272 273 %ownrecord(objinfo) DEFINEDLABEL=0, C FORWARDLABEL=0, C BEGINBLOCK=0, C TYPEIDENT=0 277 !!!!!!!!!!!!!!!!! File and control initialisation !!!!!!!!!!!!!!! 278 ! 279 %constinteger MAIN=1 280 %record(edfile)%array FILE(1:3) 281 %record(edfile)%name CUR 282 %integerarray FCONTROL(1:3) 283 %integer CURFILE,LASTFILE; !current source file no (0:3) 284 %integer CURSTART,CURLIM; !current source file bounds 285 286 %routine SET OPTIONS(%string(255) parm) 287 %constinteger CHECKS=assmask+arrbit+loopbit+capbit+overbit 288 !! define boolean params( %c C !! "ARR,LOOP,CAP,OVER,ASS,STRASS,SASS,BASS,LINE,DIAG,TRACE,STACK,".%C C !! "CHECK,SYS,STRICT,VOL,HALF,LOW,EDIT,RUN,FORCE,LOG,WARN,NONS,PERM,NEW,".%C C !! "CODE,DICT,EXP,MAP,TT,LIST",control,0) 292 !! process parameters(parm) 293 !NOCHECK => removal of checkbits 294 control = control&(\checks) %if control&checkbit = 0 295 control = control&(\editbit) %if control&listbits # 0 296 %end 297 298 %routine SET EXTENSION(%string(maxname)%name f,%string(4) ext) 299 %integer strip 300 %integer%fn last4(%string(*)%name s) 301 %integer i,e 302 i = 0; e = 0 303 %while i < length(s) %cycle 304 i = i+1; e = e<<8+charno(s,i) 305 %repeat 306 %result = e 307 %end 308 strip = last4(ext) 309 f = mainfile %and strip = which %if f = "" 310 length(f) = length(f)-4 %if last4(f)!16_202020 = strip 311 f = f.ext 312 %end 313 314 315 %routine OPEN FILES 316 %string(maxname) LISTFILE; LISTFILE="" 317 objfile = "" 318 !! define param("SOURCE",mainfile,nodefault) 319 !! define param("OFILE",objfile,newgroup) 320 !! define param("LFILE",listfile,0) 321 !! define int param("IDents",dictlim,newgroup) 322 !! define int param("KBytes",finalbound,0) 323 file(main) = 0 324 set options(cliparam) 325 control = control&(\linebit) %if control&diagbit = 0; !*temp* 326 !Main file 327 file(main)_name = mainfile; file(main)_flag = 32768 328 time1 = time1-cputime 329 !! connect edfile(file(main)) 330 time1 = time1+cputime 331 %stop %if file(main)_flag # 0 332 333 !Listing file 334 %if listfile # "" %or control&(list+ttlist) # 0 %start 335 %if control&ttlist = 0 %start 336 set extension(listfile,".lis") 337 listout = 2 338 open output(listout,listfile) 339 %finish 340 control = control&(\(editbit+ttlist)) 341 control = control!list %if control&listbits = 0 342 %finish 343 select output(listout) 344 %if control&listbits # 0 %start 345 control = control!list %if control&listbits # maplist 346 newlines(2) 347 printstring(title) 348 newlines(2) 349 printstring(" "); printstring(file(main)_name) 350 printstring(" compiled on "); printstring(date) 351 printstring(" at "); printstring(time) 352 newlines(2) 353 %finish 354 initcon = control 355 %end 356 357 time1 = 0 358 open files 359 dictlim = dictlim+300; !allow for presets 360 charbound = dictlim*8 361 finalbound = finalbound<<10+4095; !kilobytes -> bytes + (min) owns 362 lablim = dictlim+labels 363 explim = lablim+triples 364 np0 = lablim+4 365 file(main)_change = 16_7FFFFFFF 366 forwardlabel_flags = spec; forwardlabel_mode = labmode 367 definedlabel_mode = labmode 368 beginblock_mode = procmode 369 typeident_flags = typeid+recy 370 ! 371 !!!!!!!!!!!!!!!! end of file and control initialisation !!!!!!!! 372 ! 373 %record(identinfo)%array DICT(0:explim-1) 374 ! indexing DICT: 375 %integer DLIM; !dict limit (up) 376 %integer DLIM0 377 %integer DMIN; !dict upper limit (down) 378 %integer DMIN0 379 %integer DICTSHOWN 380 %integer INCLIM 381 %record(identinfo)%name DLINK,DFORMAT,DTEMP,DTEMP2,DTSPREL,DINT 382 %integer SUBBED 383 %integer RANGES 384 385 ! The identifier dictionary grows as declarations are 386 ! encountered, sequentially from 0 up, so that the 387 ! identifiers within a declaration group and within any block 388 ! are contiguous and may be processed thus (eg at block end). 389 ! However, searching is always through the hash links, with a 390 ! start-point given by the array HASHINDEX. The final link 391 ! value is zero. 392 ! Identifiers are normally added at the start of the hash list 393 ! (hence pushing down any global instance of the same name), C ! but identifiers which have been reported as 'not declared' 395 ! are added at the end of the list, using a negative link value. 396 ! This tail section is used to avoid repeated reports for the 397 ! same name (and is ultra-global, ie never removed). 398 ! 399 ! For record formats, the format name is stored in the usual way 400 ! and contains in LINK a pointer to the field-names which are linked 401 ! through what is normally the hash link. Searching for field-names 402 ! proceeds along this chain, as if following hash links. 403 ! 404 ! HLINK is the hash link (index to DICT) 405 ! 406 ! TEXT is the pointer (index to CHAR) to the text of the identifier 407 ! stored as a standard string 408 409 ! Text of identifiers (indexed by _TEXT): 410 %bytearray CHAR(0:charbound) 411 %integer CHAR0,CHARLIM,CHARMIN; !pointers 412 %integer NEWLEN 413 414 ! Hash index to DICT: 415 %shortarray HASHINDEX(0:255) 416 %shortname HEAD; !head of ident search list 417 ! 418 ! 419 !<= 0 792 anons = 2 793 %finish 794 %end 795 796 hashindex(i) = 0 %for i = 0,1,255; !hash table empty 797 byteinteger(char0) = 0; !for anon ident 798 charlim = char0+1 799 charmin = charlim+charbound; !(1 over top) 800 ranges = 0 801 802 ci = 1 803 anons = 100 804 dict(0) = 0 805 dlim = d0 806 %cycle 807 dp == dict(dlim) 808 %if dlim <= prea7 %start 809 dp = 0 810 dp_flags = okflag+writable+readable; dp_mode = dlim-d0 811 dp_type = inttype 812 textset(dp) %if dlim <= a7 813 %else 814 dp_details = record(addr(dictinit(dlim*6))) 815 textset(dp) 816 %finish 817 dlim = dlim+1 818 %exit %if control&permbit # 0 %and dlim >= signal 819 %repeat %until dlim > premax 820 dictshown = dlim 821 i = dictlim 822 %cycle 823 dp == dict(i) 824 dp = 0 825 dp_mode = labmode 826 i = i+1 827 %repeat %until i = np0 828 %end; !preset 829 830 !< BOPMAX <= OPMAX 865 ! 866 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 867 868 %integer STARTS, CYCLES 869 %integer CURLAB 870 %integer PENDOUT, PENDCOND, PENDIN, POLARITY, CONDOP 871 %ownshortinteger EXTSPECS=0, EXTERNS=0 872 ! 873 %recordformat CONTENTINFO(%short ccx,ccy,line, C %shortarray content(d0:a7)) 875 %recordformat BLOCKINF(%integer sp, stack, extra, totstack, free, status, C type, localdpos, parlim, localtext, localad, vintage, C localpc, localswpc, pid, access, forward, lab1, looplab, C eventsp, faults, return, shorts, temps, C dynarray, oldcontrol, mode,val, C %record(identinfo)%name dpid, C %record(contentinfo) reg) 882 !STATUS flag bits 883 %constinteger UNKNOWN =16_0002, C WRONGCC =16_0004, C ONSTACK =16_0008, C GLOBBED =16_0010, C LABGLOBBED =16_0020, {Pascal} C HADSPEC =16_0040, C HADSWITCH =16_0080, C HADON =16_1000, C HADORDERERR=16_2000, C HADINST =16_4000 {max flag} 893 894 %constinteger OUTERLEVEL=0, MAXLEVEL=7 895 %integer LEVEL; !current block level 896 %integer VINTAGE; !current block number 897 %record(blockinf) C; !info for current block 898 %record(blockinf)%array HOLD(0:maxlevel-1); !info for global blocks 899 %record(contentinfo)%array LREG(0:labels) 900 901 ! Code storage for currently open blocks 902 %constinteger PROGBOUND=16383 903 %shortarray PROG(0:progbound) 904 %bytearray PFLAG(0:progbound) 905 %constinteger SHORTJUMP=1, JUMP=2, LONGJUMP=3, C GLOBAL=4, {NEGGLOBAL=5, BIGGLOBAL=6,} INDGLOBAL=7, C ZEROSHORTS=8 908 %integer PC,SWPC 909 ! Final core image 910 %bytearray FINAL(0:finalbound) 911 ! Declaration records (to select relevant context) 912 %integer CAD,OWNAD,JOKERAD,OWNBASE 913 %integer FINAL0,ACCOUNTED 914 ! 915 %integer FIRSTENTRY, FIRSTPOS 916 917 !Memo variables for current statement:- 918 %own%integer {ITEM,}TYPE=0,VALUE=0; !current operand 919 %record(identinfo)%name DITEM 920 %integer SPECCING 921 %integer DUMP 922 923 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 924 925 !! Source file input and listing 926 %owninteger ATOM=0; !current lexical atom 927 %integer MATCHED; !indic that atom has been matched 928 %integer SYM; !current input symbol 929 %integer LINE; !current line number 930 %owninteger CODEFLAG=' '; !or ^ 931 %integer LISTFLAG; !' ' or '&' or '+' or '"' 932 ! Pointers to source file: 933 %integer LINESTART 934 %integer FP; !(file pointer) current position 935 %integer ATOMP; !start of current atom 936 %integer EXPP 937 ! 938 !! Utility routines 939 940 %integerfn IS SHORT(%integer v) 941 %result = TRUE %if -32768 <= v <= 32767 942 %result = FALSE 943 %end 944 945 %integerfn IS MITE(%integer v) 946 %result = TRUE %if -128 <= v <= 127 947 %result = FALSE 948 %end 949 950 %integer%fn MITE(%integer v) 951 v = v&255; v = v-256 %if v&128 # 0 952 %result = v 953 %end 954 955 %record(identinfo)%map TYPECELL(%integer t) 956 %result == dict(t) 957 %end 958 959 %integer%fn CATEGORY(%integer t) 960 %result = dict(t)_flags&(packed+cat) 961 %end 962 963 %integer%fn LITVAL(%integer v) 964 %result = v %if v = 0 965 %if v > litmax %start; !not stored literal 966 %result = (-v)>>1 %if v&1 = 0 967 %result = \((-v)>>1) 968 %finish 969 %result = litstore(v) 970 %end 971 ! 972 !!!!!!!!!!!!!! Listing, diagnostic and report routines !!!!!!!!!!!!!! 973 ! 974 %integer FAULTS, OTHERS, FAULTNUM, FAULTP 975 ! 976 !! Program statistics 977 %integer STATEMENTS; !statement count 978 %integer COMMENTS; !comment count 979 %integer ATOMS; !atom count 980 %integer IDENTATOMS; !identifier count 981 %integer LITATOMS; !numeric atom count 982 %integer ZAPS; !enforced cleardown of lits/exps 983 %integer STEPS; !stepping stones inserted 984 !%integer MAXIDENTS, MAXCHARS, MAXLITS 985 %integer JUMPS,SHORTS 986 ! 987 %string(255) REP 988 ! 989 %routine PRINT LINE 990 print string(rep); print symbol(nl) 991 rep = "" 992 %end 993 ! 994 %routine PUT SYM(%integer k) 995 rep = rep.tostring(k) 996 %end 997 ! 998 %routine PUT STRING(%string(255) s) 999 rep = rep.s 1000 %end 1001 ! 1002 ! 1003 %routine PUT NUM(%integer val) 1004 %routine PD(%integer v) 1005 pd(v//10) %and v = v-v//10*10 %if v <= -10 1006 put sym('0'-v) 1007 %end 1008 %if val < 0 %then put sym('-') %and pd(val) %c C %else pd(-val) 1010 %end 1011 ! 1012 %routine PUT IDENT(%integer p,mode) 1013 %record(identinfo)%name dp 1014 %cycle 1015 print line %if length(rep) > 50 1016 spaces(6) %if rep = "" 1017 dp == dict(p) 1018 put sym(' ') %and put sym('"') %if mode # 0 1019 %if dp_text > 0 %start 1020 put string(string(char0+dp_text)) 1021 %finish %else %if dp_text < 0 %start 1022 put num(\dp_text) 1023 %else 1024 put num(p) 1025 %finish 1026 put sym('"') %if mode # 0 1027 %return %if mode <= 0 1028 p = dp_hlink 1029 %repeat %until p = 0 1030 %end 1031 ! 1032 {?}%routine SPACES(%integer n) 1033 {?} %while n > 0 %cycle 1034 {?} put sym(' '); n = n-1 1035 {?} %repeat 1036 {?}%end 1037 {?}! 1038 {?}%routine PUT SPNUM(%integer val) 1039 {?} put sym(' ') %if val >= 0 1040 {?} put num(val) 1041 {?}%end 1042 {?} 1043 {?}%constbytearray hexsym(0:15) = 1044 {?}'0','1','2','3','4','5','6','7','8','9','A','B','C','D','E','F' 1045 {?} 1046 {?}%routine PUT HEX(%integer val) 1047 {?}%integer i 1048 {?} put sym(hexsym(val>>i&15)) %for i = 12,-4,0 1049 {?}%end 1050 {?}! 1051 {?}%routine PUT OPERAND(%integer v) 1052 {?}%integer i 1053 {?}%routine INTERPRET(%integer mode) 1054 {?}%switch s(0:7) 1055 {?} ->s(mode>>3&7) 1056 {?}s(0): !DREG 1057 {?} put sym('D') 1058 {?}putrno: 1059 {?} put sym(mode&7+'0') 1060 {?} %return 1061 {?}s(1): !AREG 1062 {?} %if mode >= framemode-dispmode %then put sym('F') %else put sym('A') 1063 {?} -> putrno 1064 {?}s(4): !PRE 1065 {?} put sym('-') 1066 {?}s(2): !INDIRECT 1067 {?}ind: 1068 {?} put sym('(') 1069 {?} interpret(mode&2_11000111+aregmode) 1070 {?} put sym(')') 1071 {?} %return 1072 {?}s(3): !POST 1073 {?} interpret(mode-8); !ind 1074 {?} put sym('+') 1075 {?} %return 1076 {?}s(5): !DISP 1077 {?} put num(i) 1078 {?} ->ind 1079 {?}s(6): !INDEX 1080 {?} put num(mite(i)) 1081 {?} put sym('(') 1082 {?} interpret(mode+(aregmode-indexmode)) 1083 {?} put sym(',') 1084 {?} interpret(i>>12&15) 1085 {?} put sym('.') 1086 {?} %if i&16_800 = 0 %then put sym('W') %else put sym('L') 1087 {?} put sym(')') 1088 {?} %return 1089 {?}s(7): !MISC 1090 {?} %if mode&63 = pcmode %start 1091 {?} put num(i) %if mode = pcmode; !suppress if not explicit 1092 {?} put string("(PC)") 1093 {?} %return 1094 {?} %finish 1095 {?} %if mode <= absmode+1 %start 1096 {?} put sym('$') 1097 {?} put hex(i>>16) %if mode = absmode+1 %or %not 0 = is short(i) 1098 {?} %else 1099 {?} put sym(hexsym(mode>>4&3)) 1100 {?} put sym(hexsym(mode&15)) 1101 {?} put sym('_') 1102 {?} %finish 1103 {?} put hex(i) 1104 {?}%end 1105 {?} 1106 {?} %if v <= 0 %start; !literal 1107 {?} v = litval(v) 1108 {?} put sym('#') 1109 {?} %if 0 = is mite(v) %then put num(v) %else %start 1110 {?} put sym('$') 1111 {?} put hex(v>>16) %if v>>16 # 0 1112 {?} put hex(v&16_FFFF) 1113 {?} %finish 1114 {?} %finish %else %if v <= prea7 %start; !register 1115 {?} interpret(v-d0) 1116 {?} %finish %else %if v < dictlim %start; !identifier 1117 {?} put ident(v,0) 1118 {?} %finish %else %if v < lablim %start; !internal label 1119 {?} put sym('L') 1120 {?} put num(v-dictlim) 1121 {?} %else; !complex 1122 {?} i = dict(v)_val 1123 {?} interpret(dict(v)_mode) 1124 {?} %finish 1125 {?}%end; !put operand 1126 {?} 1127 {?}%routine MARK AT(%integer col) 1128 {?} put sym(' ') %while length(rep) < col; put sym('|') 1129 {?}%end 1130 {?}! 1131 {?}%routine SHOW DICT(%integer from) 1132 {?}%integer i 1133 {?}%record(identinfo) d 1134 {?}%constbytearray flagsym(0:15) = 1135 {?} 'W','R','V','A','w','r','o','m','S','T','K','?','P','p','E','*' 1136 {?}%constbytearray catsym(0:15) = 1137 {?} 'I', 'C', 'B', 'E', '@', 'X', '?', '?', C {?} 'S', 'A', 'Z', '?', 'R', 'F', '?', '?' 1139 {?} 1140 {?} %return %if from >= dlim 1141 !< 0 %start 1152 {?} i = char0+d_text; i = i+byteinteger(i)+1 1153 {?} %if byteinteger(i)&128 # 0 %start 1154 {?} byteinteger(i) = byteinteger(i)-128 1155 {?} put sym(':'); put string(string(i)) 1156 {?} byteinteger(i) = byteinteger(i)+128 1157 {?} %finish 1158 {?} %finish 1159 {?} mark at(22) 1160 {?} %if d_flags&typeid # 0 %then put sym(catsym(d_flags&cat)) %and i = 4 %c C {?} %else put sym(' ') %and i = 0 1162 {?} %cycle 1163 {?} put sym(flagsym(i)) %if d_flags>>i&1 # 0 1164 {?} i = i+1 1165 {?} %repeat %until i > 15 1166 {?} mark at(30) 1167 {?} put spnum(d_type); mark at(35) 1168 {?} put spnum(d_link); mark at(42) 1169 {?} put spnum(d_reg); mark at(46) 1170 {?} put spnum(d_mode); mark at(51) 1171 {?} put spnum(d_val); mark at(63) 1172 {?} print line 1173 {?} from = from+1 1174 {?} %repeat %until from = dlim 1175 {?} spaces(6) 1176 {?} put string("+-------------------------------------------------------+") 1177 {?} print line 1178 !<>27+'A'-1) 1184 {?} m = m<<5 1185 {?} %repeat %until m = 0 1186 {?}%end 1187 {?}%routine%spec PUT OPCODE(%integer op) 1188 {?}%routine SHOW EXP(%integer startp) 1189 {?}%integer p,q 1190 {?}%record(identinfo)%name dp 1191 {?} 1192 %constinteger bopmax=51 1193 %constintegerarray EXTRA(32:bopmax) = 1194 'j'<<25+('a'&31)<<20+('m'&31)<<15+('a'&31)<<10+('s'&31)<<5+('s'&31), C 'o'<<25+('k'&31)<<20+('a'&31)<<15+('s'&31)<<10+('s'&31)<<5, C 'a'<<25+('s'&31)<<20+('s'&31)<<15+('i'&31)<<10+('g'&31)<<5+('n'&31), C 'i'<<25+('n'&31)<<20+('c'&31)<<15+('a'&31)<<10+('s'&31)<<5+('s'&31), C 'f'<<25+('o'&31)<<20+('r'&31)<<15+('a'&31)<<10+('s'&31)<<5+('s'&31), C 's'<<25+('t'&31)<<20+('o'&31)<<15+('p'&31)<<10, C 'r'<<25+('e'&31)<<20+('t'&31)<<15+('u'&31)<<10+('r'&31)<<5+('n'&31), C 'r'<<25+('e'&31)<<20+('p'&31)<<15+('e'&31)<<10+('a'&31)<<5+('t'&31), C 'e'<<25+('l'&31)<<20+('s'&31)<<15+('e'&31)<<10, C 'e'<<25+('x'&31)<<20+('i'&31)<<15+('t'&31)<<10, C 't'<<25+('r'&31)<<20+('a'&31)<<15+('p'&31)<<10, C 's'<<25+('w'&31)<<20+('g'&31)<<15+('o'&31)<<10+('t'&31)<<5+('o'&31), C 'l'<<25+('a'&31)<<20+('b'&31)<<15+('e'&31)<<10+('l'&31)<<5, C 'r'<<25+('e'&31)<<20+('c'&31)<<15+('r'&31)<<10+('e'&31)<<5+('f'&31), C 'p'<<25+('r'&31)<<20+('e'&31)<<15+('l'&31)<<10, C 's'<<25+('t'&31)<<20+('r'&31)<<15+('m'&31)<<10+('a'&31)<<5+('p'&31), C 'i'<<25+('a'&31)<<20+('b'&31)<<15+('s'&31)<<10, C 'f'<<25+('a'&31)<<20+('b'&31)<<15+('s'&31)<<10, C 'e'<<25+('n'&31)<<20+('d'&31)<<15, C 'l'<<25+('o'&31)<<20+('g'&31)<<15+('s'&31)<<10+('u'&31)<<5+('b'&31) 1214 1215 {?}%routine PUT OPRAND(%integer v) 1216 {?} put sym('#') %and v = v-ad %if v >= explim 1217 {?} %if v < np0 %then put operand(v) %else put num(v) 1218 {?}%end 1219 {?} print line %if rep # "" 1220 {?} %return %unless np > np0 1221 {?} put string(" ______action_______first_______second____") 1222 {?} print line 1223 {?} p = np0 1224 {?} %cycle 1225 {?} %if p = np %start 1226 {?} p = explo 1227 {?} %exit %if p >= oldexplo 1228 {?} put string(" |---------------------------------------|") 1229 {?} print line 1230 {?} %finish 1231 {?} %if p = startp %then put sym('>') %else put sym(' ') 1232 {?} put num(p); mark at(6) 1233 {?} dp == dict(p) 1234 {?} put sym(' ') 1235 {?} q = dp_act 1236 {?} %if q <= 31 %start 1237 {?} put opcode(q) 1238 {?} %finish %else %if q <= bopmax %start 1239 {?} put mnemonic(extra(q)) 1240 {?} %else 1241 {?} put ident(q,0) 1242 {?} %finish 1243 {?} mark at(22) 1244 {?} put sym(' '); put oprand(dp_x); mark at(34) 1245 {?} put sym(' '); put oprand(dp_y); mark at(46) 1246 {?} %if p >= explo %start 1247 {?} put spnum(dp_type) 1248 {?} put sym('*') %if dp_flags < 0 1249 {?} %finish 1250 {?} print line 1251 {?} p = p+1 1252 {?} %repeat %until p >= oldexplo 1253 {?} oldexplo = explo 1254 {?} put string(" +---------------------------------------+") 1255 {?} print line 1256 {?}%end 1257 {?}! 1258 ! 1259 !!!!!!!!!!!!!!!!!!!!!!!!!!!! Fault reporting !!!!!!!!!!!!!!!!!!!!!!!!!!! 1260 ! 1261 %routine CROAK(%string(255) s) 1262 select output(0) 1263 put string("** "); put string(s) 1264 put string(". Compilation abandoned at line "); put num(line) 1265 print line 1266 %signal abandon 1267 %end 1268 1269 !<= counterr %start 1332 %if k = counterr %start 1333 %if num < 0 %start 1334 put num(-num); put string(" extra") 1335 %else 1336 put num(num) %if num # 0; put string(" missing") 1337 %finish 1338 put string(" value(s) for ") 1339 put ident(id,0) 1340 %return 1341 %finish 1342 %if k # slabmissing %start 1343 put ident(id,1) 1344 %else 1345 put ident(id,0) 1346 put sym('('); put num(num); put sym(')') 1347 %finish 1348 put string(" missing") 1349 mend: 1350 %if c_dpid_text # 0 %start 1351 put string(" in ") 1352 put ident(c_pid,-1) 1353 %finish 1354 %return 1355 %finish 1356 put ident(id,0) %if id > 0 1357 put string(message(k)) 1358 put num(num) %if num > 0 1359 -> mend %if creacherr <= k <= noresult 1360 spaces(22-length(rep)) 1361 p = start 1362 p = p+1 %while byteinteger(p) = ' ' 1363 %if p < faultp-50 %then p = faultp-47 %and put string("...") %c C %else put sym(' ') 1365 %cycle 1366 k = byteintegeR(p); p = p+1 1367 %if p = faultp %start 1368 ! %if stream # 0 %then put sym('|') %else %start 1369 ! !**V200** 1370 ! put sym(esc); put sym('F'); !graphics 1371 ! put sym('~') 1372 ! put sym(esc); put sym('G'); !normal 1373 ! %finish 1374 put sym('|') 1375 %finish 1376 %exit %if k = nl 1377 put sym(k) 1378 ! %if ' ' <= k <= '~' %then put sym(k) %c C ! %else put sym('[') %and put num(k) %and put sym(']') 1380 %repeat 1381 %return 1382 %end 1383 1384 !Warning or error 1385 mark = '?' 1386 %if n > 0 %start 1387 mark = '*' 1388 c_faults = c_faults+1; faults = faults+1 1389 %finish 1390 faultnum = 0; c_access = -1 1391 !Ignore uncorrected earlier error 1392 %return %if file(main)_start1 <= fp < lastchange 1393 !Establish what to print 1394 start = linestart; errline = line 1395 %if n&point = 0 %start 1396 faultp = 0; !no pointing 1397 %else 1398 %while start >= faultp %cycle; !before current line 1399 start = start-1 1400 errline = errline-1 %if byteintegeR(start) = nl 1401 %repeat 1402 start = start-1 %while start # curstart %and byteintegeR(start-1) # nl 1403 %finish 1404 time1 = time1-cputime 1405 %if listout # 0 %start; !listing file 1406 print text(listout); print line 1407 %finish 1408 select output(0) 1409 %if curfile # lastfile %start 1410 lastfile = curfile; put string(cur_name); print line 1411 %finish 1412 print text(0) 1413 %if n > reacherr %and curfile = main %and control&editbit # 0 %start 1414 start = faultp-1 %if faultp > start 1415 cur_fp = start; cur_line = line 1416 cur_change = 16_7FFFFFFE %if lastchange # 0 1417 select input(0) 1418 file(main+1) = 0 1419 !! edi(file(main),file(main+1),rep); !main+1 to keep editor happy 1420 rep = "" 1421 select output(listout) 1422 time1 = time1+cputime 1423 %signal abandon %if cur_flag < 0 {abandoned} 1424 control = control&(\editbit) %if cur_flag = 'I' 1425 lastchange = cur_change %and %signal redo %if cur_change < 16_7FFFFFFE 1426 %else 1427 print line 1428 select output(listout) 1429 time1 = time1+cputime 1430 %finish 1431 %end; !report 1432 1433 %routine FAULT(%integer n) 1434 !Note fault number and position of (earliest) fault 1435 ! for subsequent reporting (warnings and weak errors) 1436 %if faultnum = 0 %or (n > 0 %and faultnum < 0) %start 1437 faultnum = n; faultp = atomp 1438 report(faultnum&127,0,0) %if faultnum >= now 1439 %finish 1440 %end 1441 1442 %routine INTERN(%integer n) 1443 report(internerr,0,n) 1444 %end 1445 1446 !!!!!!!!!!!!!!!!!!!! CELL CONSTRUCTORS !!!!!!!!!!!!!!!!!!! 1447 ! 1448 %integer%fn LITREF(%integer v) 1449 %integer i 1450 %result = v %if v = 0 1451 %if v > 0 %start 1452 %result = -(v<<1) %if v <= smallmax 1453 %else 1454 %result = v<<1+1 %if v >= smallmin 1455 %finish 1456 litstore(litpos) = v 1457 i = litmin-1 1458 i = i+1 %until litstore(i) = v 1459 %if i = litpos %start 1460 litpos = litpos+1 1461 croak("Too many literals") %if litpos >= litmax 1462 %finish 1463 %result = i 1464 %end 1465 ! 1466 %routine PUTEXP(%integer act,x,y,t) 1467 type = t 1468 item = explim 1469 item = x %if explo <= x < item 1470 item = y %if explo <= y < item 1471 %cycle 1472 item = item-1 1473 ditem == dict(item) 1474 %if item < explo %start 1475 explo = item 1476 ditem_act = act; ditem_x = x; ditem_y = y 1477 ditem_flags = 0; ditem_type = t; ditem_mode = 0 1478 %exit 1479 %finish 1480 %repeat %until ditem_act = act %and ditem_x = x %and ditem_y = y 1481 %end 1482 1483 !$IF VAX 1484 {%integer%fn IEEE(%integer v) 1485 { %result = 0 %if v = 0 1486 { %result = v<<16+v>>16-16_01000000 1487 {%end 1488 !$FINISH 1489 1490 %routine PUTEXP2(%integer op,first,t) 1491 %if item = 0 %start 1492 !$IF VAX 1493 { value = ieee(value) %if type = realtype; !vax->ieee 1494 !$FINISH 1495 item = litref(value) 1496 %finish 1497 putexp(op,first,item,t) 1498 %end 1499 1500 %integer%fn NORMITEM 1501 %result = item %if item # 0 1502 !$IF VAX 1503 { value = ieee(value) %if type = realtype; !vax->ieee 1504 !$FINISH 1505 %result = litref(value) 1506 %end 1507 1508 %routine TOREAL 1509 %if item # 0 %then putexp(float,item,0,realtype) %c C %else real(addr(value)) = value %and type = realtype 1511 %end 1512 1513 %integer%fn TEMP(%integer m,v) 1514 dtemp_mode = m; dtemp_val = v 1515 %result = lablim 1516 %end 1517 %integer%fn TEMPX(%integer r1,r2) 1518 dtemp_mode = r1+(indexmode-a0); dtemp_val = (r2-d0)<<12+16_0800 1519 %result = lablim 1520 %end 1521 %integer%fn TEMPD(%integer a,disp) 1522 dtemp_mode = a+(dispmode-a0); dtemp_val = disp 1523 %result = lablim 1524 %end 1525 %integer%fn TEMPX2(%integer r1,r2) 1526 dtemp2_mode = r1+(indexmode-a0); dtemp2_val = (r2-d0)<<12+16_0800 1527 %result = lablim+1 1528 %end 1529 1530 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 1531 !!!!!!!!!!!!!!!!! CODE GENERATION !!!!!!!!!!!!!!!!!!!!!!!! 1532 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 1533 ! 1534 ! The array DEF contains packed mnemonics for M68000 machine 1535 ! instructions and, for each mnemonic, the basic opcode and 1536 ! a type indicator. 1537 ! The type indicator contains flag bits for various special cases 1538 ! and two 6-bit fields defining the operand types 1539 ! [should be const record array] 1540 ! The mnemonics and variant distinctions broadly follow the 1541 ! manufacturer's Assembly Language conventions 1542 ! 1543 ! Opcode index values needed globally:- 1544 %constinteger LEA=78, PEA=55, CLR=52, DBRA=81, JSR=56, C LINK=72, UNLK=73, RTS=68, C MOVEM=100, TRAPI=101, DC=102 1547 1548 !Machine-code operand types 1549 ![EA needs to be further distinguished] 1550 %constinteger SHIFT=32 1551 %constinteger REG=1, AREG=2, IREG=3, QUICK=4, MQUICK=5 1552 %constinteger EA=6, RWEA=7, WEA=8 1553 %constinteger IMM=9, TQUICK=10, REL=11, LONGREL=12 1554 %constinteger QREG=13, POSTAREG=14, QEA=15 1555 %constinteger REVEA=16, XIMM=17, DATA=18, PREAREG=19, QPRE=20 1556 %constinteger EXREG=21+shift 1557 %constinteger REG9=reg+shift, QREG9=qreg+shift, IREG9=ireg+shift, C POSTAREG9=postareg+shift, C QUICK9=quick+shift, AREG9=areg+shift 1560 %constinteger SIZED=1<<15, ASIZED=1<<14; !2 spare bits 1561 %constinteger REVERSIBLE=revea<<6+reg9+sized, MULTIPLE=ximm<<6+ea+asized 1562 %constinteger DEFMAX=129 1563 %constintegerarray DEF(0:defmax+defmax) = 1564 0, C {MOVE} 16_0000<<16+ ea<<6+wea+shift +sized, C 'm'<<25+('o'&31)<<20+('v'&31)<<15+('e'&31)<<10, C {ADD} 16_D000<<16+ reversible, C 'a'<<25+('d'&31)<<20+('d'&31)<<15, C {SUB} 16_9000<<16+ reversible, C 's'<<25+('u'&31)<<20+('b'&31)<<15, C {CMP} 16_B000<<16+ ea<<6+reg9 +sized, C 'c'<<25+('m'&31)<<20+('p'&31)<<15, C {AND} 16_C000<<16+ reversible, C 'a'<<25+('n'&31)<<20+('d'&31)<<15, C {OR} 16_8000<<16+ reversible, C 'o'<<25+('r'&31)<<20, C {EOR} 16_B100<<16+ reg9<<6+rwea +sized, C 'e'<<25+('o'&31)<<20+('r'&31)<<15, C {NOT} 16_4600<<16+ rwea +sized, C 'n'<<25+('o'&31)<<20+('t'&31)<<15, C {NEG} 16_4400<<16+ rwea +sized, C 'n'<<25+('e'&31)<<20+('g'&31)<<15, C {LSL} 16_E108<<16+ qreg9<<6+reg +sized, C 'l'<<25+('s'&31)<<20+('l'&31)<<15, C {LSR} 16_E008<<16+ qreg9<<6+reg +sized, C 'l'<<25+('s'&31)<<20+('r'&31)<<15, C {MULS} 16_C1C0<<16+ ea<<6+reg9, C 'm'<<25+('u'&31)<<20+('l'&31)<<15+('s'&31)<<10, C {DIVS} 16_81C0<<16+ ea<<6+reg9, C 'd'<<25+('i'&31)<<20+('v'&31)<<15+('s'&31)<<10, C {MULU} 16_C0C0<<16+ ea<<6+reg9, C 'm'<<25+('u'&31)<<20+('l'&31)<<15+('u'&31)<<10, C {DIVU} 16_80C0<<16+ ea<<6+reg9, C 'd'<<25+('i'&31)<<20+('v'&31)<<15+('u'&31)<<10, C {BRA} 16_6000<<16+ rel, C 'b'<<25+('r'&31)<<20+('a'&31)<<15, C {BSR} 16_6100<<16+ rel, C 'b'<<25+('s'&31)<<20+('r'&31)<<15, C {BHI} 16_6200<<16+ rel, C 'b'<<25+('h'&31)<<20+('i'&31)<<15, C {BLS} 16_6300<<16+ rel, C 'b'<<25+('l'&31)<<20+('s'&31)<<15, C {BCC} 16_6400<<16+ rel, C 'b'<<25+('c'&31)<<20+('c'&31)<<15, C {BCS} 16_6500<<16+ rel, C 'b'<<25+('c'&31)<<20+('s'&31)<<15, C {BNE} 16_6600<<16+ rel, C 'b'<<25+('n'&31)<<20+('e'&31)<<15, C {BEQ} 16_6700<<16+ rel, C 'b'<<25+('e'&31)<<20+('q'&31)<<15, C {BVC} 16_6800<<16+ rel, C 'b'<<25+('v'&31)<<20+('c'&31)<<15, C {BVS} 16_6900<<16+ rel, C 'b'<<25+('v'&31)<<20+('s'&31)<<15, C {BPL} 16_6A00<<16+ rel, C 'b'<<25+('p'&31)<<20+('l'&31)<<15, C {BMI} 16_6B00<<16+ rel, C 'b'<<25+('m'&31)<<20+('i'&31)<<15, C {BGE} 16_6C00<<16+ rel, C 'b'<<25+('g'&31)<<20+('e'&31)<<15, C {BLT} 16_6D00<<16+ rel, C 'b'<<25+('l'&31)<<20+('t'&31)<<15, C {BGT} 16_6E00<<16+ rel, C 'b'<<25+('g'&31)<<20+('t'&31)<<15, C {BLE} 16_6F00<<16+ rel, C 'b'<<25+('l'&31)<<20+('e'&31)<<15, C {ASL} 16_E100<<16+ qreg9<<6+reg +sized, C 'a'<<25+('s'&31)<<20+('l'&31)<<15, C {ASR} 16_E000<<16+ qreg9<<6+reg +sized, C 'a'<<25+('s'&31)<<20+('r'&31)<<15, C {ROL} 16_E118<<16+ qreg9<<6+reg +sized, C 'r'<<25+('o'&31)<<20+('l'&31)<<15, C {ROR} 16_E018<<16+ qreg9<<6+reg +sized, C 'r'<<25+('o'&31)<<20+('r'&31)<<15, C {MOVEQ} 16_7000<<16+ mquick<<6+reg9, C 'm'<<25+('o'&31)<<20+('v'&31)<<15+('e'&31)<<10+('q'&31)<<5, C {ADDQ} 16_5000<<16+ quick9<<6+rwea +sized, C 'a'<<25+('d'&31)<<20+('d'&31)<<15+('q'&31)<<10, C {SUBQ} 16_5100<<16+ quick9<<6+rwea +sized, C 's'<<25+('u'&31)<<20+('b'&31)<<15+('q'&31)<<10, C {MOVEA} 16_3040<<16+ ea<<6+areg9 +asized, C 'm'<<25+('o'&31)<<20+('v'&31)<<15+('e'&31)<<10+('a'&31)<<5, C {ADDA} 16_D0C0<<16+ ea<<6+areg9 +asized, C 'a'<<25+('d'&31)<<20+('d'&31)<<15+('a'&31)<<10, C {SUBA} 16_90C0<<16+ ea<<6+areg9 +asized, C 's'<<25+('u'&31)<<20+('b'&31)<<15+('a'&31)<<10, C {CMPA} 16_B0C0<<16+ ea<<6+areg9 +asized, C 'c'<<25+('m'&31)<<20+('p'&31)<<15+('a'&31)<<10, C {CMPM} 16_B108<<16+ postareg<<6+postareg9, C 'c'<<25+('m'&31)<<20+('p'&31)<<15+('m'&31)<<10, C {ADDI} 16_0600<<16+ imm<<6+rwea +sized, C 'a'<<25+('d'&31)<<20+('d'&31)<<15+('i'&31)<<10, C {SUBI} 16_0400<<16+ imm<<6+rwea +sized, C 's'<<25+('u'&31)<<20+('b'&31)<<15+('i'&31)<<10, C {CMPI} 16_0C00<<16+ imm<<6+ea +sized, C 'c'<<25+('m'&31)<<20+('p'&31)<<15+('i'&31)<<10, C {ANDI} 16_0200<<16+ imm<<6+rwea +sized, C 'a'<<25+('n'&31)<<20+('d'&31)<<15+('i'&31)<<10, C {ORI} 16_0000<<16+ imm<<6+rwea +sized, C 'o'<<25+('r'&31)<<20+('i'&31)<<15, C {EORI} 16_0A00<<16+ imm<<6+rwea +sized, C 'e'<<25+('o'&31)<<20+('r'&31)<<15+('i'&31)<<10, C {ROXL} 16_E110<<16+ qreg9<<6+reg +sized, C 'r'<<25+('o'&31)<<20+('x'&31)<<15+('l'&31)<<10, C {ROXR} 16_E010<<16+ qreg9<<6+reg +sized, C 'r'<<25+('o'&31)<<20+('x'&31)<<15+('r'&31)<<10, C {CLR} 16_4200<<16+ wea +sized, C 'c'<<25+('l'&31)<<20+('r'&31)<<15, C {NEGX} 16_4000<<16+ rwea +sized, C 'n'<<25+('e'&31)<<20+('g'&31)<<15+('x'&31)<<10, C {NBCD} 16_4800<<16+ rwea, C 'n'<<25+('b'&31)<<20+('c'&31)<<15+('d'&31)<<10, C {PEA} 16_4840<<16+ ea, C 'p'<<25+('e'&31)<<20+('a'&31)<<15, C {JSR} 16_4E80<<16+ ea, C 'j'<<25+('s'&31)<<20+('r'&31)<<15, C {JMP} 16_4EC0<<16+ ea, C 'j'<<25+('m'&31)<<20+('p'&31)<<15, C {TAS} 16_4AC0<<16+ rwea, C 't'<<25+('a'&31)<<20+('s'&31)<<15, C {TST} 16_4A00<<16+ ea +sized, C 't'<<25+('s'&31)<<20+('t'&31)<<15, C {ABCD} 16_C100<<16+ qpre<<6+reg9, C 'a'<<25+('b'&31)<<20+('c'&31)<<15+('d'&31)<<10, C {SBCD} 16_8100<<16+ qpre<<6+reg9, C 's'<<25+('b'&31)<<20+('c'&31)<<15+('d'&31)<<10, C {ADDX} 16_D100<<16+ qpre<<6+reg9 +sized, C 'a'<<25+('d'&31)<<20+('d'&31)<<15+('x'&31)<<10, C {SUBX} 16_9100<<16+ qpre<<6+reg9 +sized, C 's'<<25+('u'&31)<<20+('b'&31)<<15+('x'&31)<<10, C {NOP} 16_4E71<<16, C 'n'<<25+('o'&31)<<20+('p'&31)<<15, C {RESET} 16_4E70<<16, C 'r'<<25+('e'&31)<<20+('s'&31)<<15+('e'&31)<<10+('t'&31)<<5, C {RTE} 16_4E73<<16, C 'r'<<25+('t'&31)<<20+('e'&31)<<15, C {RTR} 16_4E77<<16, C 'r'<<25+('t'&31)<<20+('r'&31)<<15, C {RTS} 16_4E75<<16, C 'r'<<25+('t'&31)<<20+('s'&31)<<15, C {STOP} 16_4E72<<16 +imm, C 's'<<25+('t'&31)<<20+('o'&31)<<15+('p'&31)<<10, C {TRAPV} 16_4E76<<16, C 't'<<25+('r'&31)<<20+('a'&31)<<15+('p'&31)<<10+('v'&31)<<5, C {TRAP} 16_4E40<<16+ tquick, C 't'<<25+('r'&31)<<20+('a'&31)<<15+('p'&31)<<10, C {LINK} 16_4E50<<16+ imm<<6+areg, C 'l'<<25+('i'&31)<<20+('n'&31)<<15+('k'&31)<<10, C {UNLK} 16_4E58<<16+ areg, C 'u'<<25+('n'&31)<<20+('l'&31)<<15+('k'&31)<<10, C {SWAP} 16_4840<<16+ reg, C 's'<<25+('w'&31)<<20+('a'&31)<<15+('p'&31)<<10, C {EXTW} 16_4880<<16+ reg, C 'e'<<25+('x'&31)<<20+('t'&31)<<15+('w'&31)<<10, C {EXTL} 16_48C0<<16+ reg, C 'e'<<25+('x'&31)<<20+('t'&31)<<15+('l'&31)<<10, C {EXG} 16_C140<<16+ exreg<<6+reg, C 'e'<<25+('x'&31)<<20+('g'&31)<<15, C {LEA} 16_41C0<<16+ qea<<6+areg9, C 'l'<<25+('e'&31)<<20+('a'&31)<<15, C {CHK} 16_4180<<16+ ea<<6+reg9, C 'c'<<25+('h'&31)<<20+('k'&31)<<15, C {DBXX} 16_50C8<<16+ reg<<6+longrel, C 'd'<<25+('b'&31)<<20+('x'&31)<<15+('x'&31)<<10, C {DBRA} 16_51C8<<16+ reg<<6+longrel, C 'd'<<25+('b'&31)<<20+('r'&31)<<15+('a'&31)<<10, C {DBHI} 16_52C8<<16+ reg<<6+longrel, C 'd'<<25+('b'&31)<<20+('h'&31)<<15+('i'&31)<<10, C {DBLS} 16_53C8<<16+ reg<<6+longrel, C 'd'<<25+('b'&31)<<20+('l'&31)<<15+('s'&31)<<10, C {DBCC} 16_54C8<<16+ reg<<6+longrel, C 'd'<<25+('b'&31)<<20+('c'&31)<<15+('c'&31)<<10, C {DBCS} 16_55C8<<16+ reg<<6+longrel, C 'd'<<25+('b'&31)<<20+('c'&31)<<15+('s'&31)<<10, C {DBNE} 16_56C8<<16+ reg<<6+longrel, C 'd'<<25+('b'&31)<<20+('n'&31)<<15+('e'&31)<<10, C {DBEQ} 16_57C8<<16+ reg<<6+longrel, C 'd'<<25+('b'&31)<<20+('e'&31)<<15+('q'&31)<<10, C {DBVC} 16_58C8<<16+ reg<<6+longrel, C 'd'<<25+('b'&31)<<20+('v'&31)<<15+('c'&31)<<10, C {DBVS} 16_59C8<<16+ reg<<6+longrel, C 'd'<<25+('b'&31)<<20+('v'&31)<<15+('s'&31)<<10, C {DBPL} 16_5AC8<<16+ reg<<6+longrel, C 'd'<<25+('b'&31)<<20+('p'&31)<<15+('l'&31)<<10, C {DBMI} 16_5BC8<<16+ reg<<6+longrel, C 'd'<<25+('b'&31)<<20+('m'&31)<<15+('i'&31)<<10, C {DBGE} 16_5CC8<<16+ reg<<6+longrel, C 'd'<<25+('b'&31)<<20+('g'&31)<<15+('e'&31)<<10, C {DBLT} 16_5DC8<<16+ reg<<6+longrel, C 'd'<<25+('b'&31)<<20+('l'&31)<<15+('t'&31)<<10, C {DBGT} 16_5EC8<<16+ reg<<6+longrel, C 'd'<<25+('b'&31)<<20+('g'&31)<<15+('t'&31)<<10, C {DBLE} 16_5FC8<<16+ reg<<6+longrel, C 'd'<<25+('b'&31)<<20+('l'&31)<<15+('e'&31)<<10, C {BCHG} 16_0140<<16+ ireg9<<6+rwea, C 'b'<<25+('c'&31)<<20+('h'&31)<<15+('g'&31)<<10, C {BCLR} 16_0180<<16+ ireg9<<6+wea, C 'b'<<25+('c'&31)<<20+('l'&31)<<15+('r'&31)<<10, C {BSET} 16_01C0<<16+ ireg9<<6+wea, C 'b'<<25+('s'&31)<<20+('e'&31)<<15+('t'&31)<<10, C {BTST} 16_0100<<16+ ireg9<<6+ea, C 'b'<<25+('t'&31)<<20+('s'&31)<<15+('t'&31)<<10, C {MOVEM} 16_4880<<16+ multiple, C 'm'<<25+('o'&31)<<20+('v'&31)<<15+('e'&31)<<10+('m'&31)<<5, C {TRAPI} 16_4E40<<16+ imm<<6+tquick, C 't'<<25+('r'&31)<<20+('a'&31)<<15+('p'&31)<<10+('i'&31)<<5, C {DC} data, C 'd'<<25+('c'&31)<<20, C {ST} 16_50C0<<16+ wea, C 's'<<25+('t'&31)<<20, C {SF} 16_51C0<<16+ wea, C 's'<<25+('f'&31)<<20, C {SHI} 16_52C0<<16+ wea, C 's'<<25+('h'&31)<<20+('i'&31)<<15, C {SLS} 16_53C0<<16+ wea, C 's'<<25+('l'&31)<<20+('s'&31)<<15, C {SCC} 16_54C0<<16+ wea, C 's'<<25+('c'&31)<<20+('c'&31)<<15, C {SCS} 16_55C0<<16+ wea, C 's'<<25+('c'&31)<<20+('s'&31)<<15, C {SNE} 16_56C0<<16+ wea, C 's'<<25+('n'&31)<<20+('e'&31)<<15, C {SEQ} 16_57C0<<16+ wea, C 's'<<25+('e'&31)<<20+('q'&31)<<15, C {SVC} 16_58C0<<16+ wea, C 's'<<25+('v'&31)<<20+('c'&31)<<15, C {SVS} 16_59C0<<16+ wea, C 's'<<25+('v'&31)<<20+('s'&31)<<15, C {SPL} 16_5AC0<<16+ wea, C 's'<<25+('p'&31)<<20+('l'&31)<<15, C {SMI} 16_5BC0<<16+ wea, C 's'<<25+('m'&31)<<20+('i'&31)<<15, C {SGE} 16_5CC0<<16+ wea, C 's'<<25+('g'&31)<<20+('e'&31)<<15, C {SLT} 16_5DC0<<16+ wea, C 's'<<25+('l'&31)<<20+('t'&31)<<15, C {SGT} 16_5EC0<<16+ wea, C 's'<<25+('g'&31)<<20+('t'&31)<<15, C {SLE} 16_5FC0<<16+ wea, C 's'<<25+('l'&31)<<20+('e'&31)<<15, C {MTCCR} 16_44C0<<16+ ea<<6, C 'm'<<25+('t'&31)<<20+('c'&31)<<15+('c'&31)<<10+('r'&31)<<5, C {MTSR} 16_46C0<<16+ ea<<6, C 'm'<<25+('t'&31)<<20+('s'&31)<<15+('r'&31)<<10, C {MFSR} 16_40C0<<16+ wea, C 'm'<<25+('f'&31)<<20+('s'&31)<<15+('r'&31)<<10, C {MTUSP} 16_4E60<<16+ areg, C 'm'<<25+('t'&31)<<20+('u'&31)<<15+('s'&31)<<10+('p'&31)<<5, C {MFUSP} 16_4E68<<16+ areg, C 'm'<<25+('f'&31)<<20+('u'&31)<<15+('s'&31)<<10+('p'&31)<<5, C {ATCCR} 16_023C<<16+ imm, C 'a'<<25+('t'&31)<<20+('c'&31)<<15+('c'&31)<<10+('r'&31)<<5, C {ATSR} 16_027C<<16+ imm, C 'a'<<25+('t'&31)<<20+('s'&31)<<15+('r'&31)<<10, C {ETCCR} 16_0A3C<<16+ imm, C 'e'<<25+('t'&31)<<20+('c'&31)<<15+('c'&31)<<10+('r'&31)<<5, C {ETSR} 16_0A7C<<16+ imm, C 'e'<<25+('t'&31)<<20+('s'&31)<<15+('r'&31)<<10, C {OTCCR} 16_003C<<16+ imm, C 'o'<<25+('t'&31)<<20+('c'&31)<<15+('c'&31)<<10+('r'&31)<<5, C {OTSR} 16_007C<<16+ imm, C 'o'<<25+('t'&31)<<20+('s'&31)<<15+('r'&31)<<10 1823 1824 {?}%routine PUT OPCODE(%integer op) 1825 {?} put mnemonic(def(op+op)) 1826 {?}%end 1827 1828 %routine STORE(%integer v,f) 1829 !$IF VAX 1830 { v = v&16_FFFF; v = v!sign16 %if v&sign16 # 0 1831 !$FINISH 1832 prog(pc) <- v; pflag(pc) = f; pc = pc+1 1833 %end 1834 1835 %routine MAKE ROOM(%integer size) 1836 %integer newbase,newlim 1837 size = (size+127)&(\127) 1838 ownbase = ownbase-size 1839 croak("Program too big") %if ownbase <= cad 1840 newbase = ownbase; newlim = newbase+ownad 1841 %cycle 1842 final(newbase) = final(newbase+size) 1843 newbase = newbase+1 1844 %repeat %until newbase >= newlim 1845 %end 1846 1847 %routine FILL CODE(%integer n) 1848 %integer i 1849 i = cad; cad = cad+n 1850 %while n > 0 %cycle 1851 final(i) = 16_80; i = i+1; n = n-1 1852 %repeat 1853 %end 1854 %routine FILL OWN(%integer n) 1855 %integer i 1856 make room(n) 1857 i = ownbase+ownad; ownad = ownad+n 1858 %while n > 0 %cycle 1859 final(i) = 16_80; i = i+1; n = n-1 1860 %repeat 1861 %end 1862 1863 %routine SET CODE WORD(%integer v) 1864 !$IF VAX (works irrespective of host byte sex) 1865 { final(cad) <- v>>8; final(cad+1) <- v 1866 !$IF APM (for efficiency) 1867 shortinteger(final0+cad) <- v 1868 !$FINISH 1869 cad = cad+2 1870 %end 1871 1872 %integer%fn CODE WORD(%integer cad) 1873 !$IF VAX (works irrespective of host byte sex) 1874 { %result = final(cad)<<8+final(cad+1) 1875 !$IF APM (for efficiency) 1876 %result = shortinteger(final0+cad) 1877 !$FINISH 1878 %end 1879 1880 %routine SET CODE LONGWORD(%integer v) 1881 set code word(v>>16); set code word(v) 1882 %end 1883 1884 %routine SET OWN WORD(%integer v) 1885 make room(2) %if ownbase+ownad > finalbound 1886 !$IF VAX 1887 { final(ownbase+ownad) <- v>>8; final(ownbase+ownad+1) <- v 1888 !$IF APM 1889 shortinteger(final0+ownbase+ownad) <- v 1890 !$FINISH 1891 ownad = ownad+2 1892 %end 1893 1894 %routine EXTEND STACK(%integer delta) 1895 c_sp = c_sp-delta 1896 %if c_sp < c_stack %start 1897 c_stack = c_sp 1898 c_totstack = c_stack %if c_stack < c_totstack 1899 %finish 1900 %end 1901 1902 %routine PLANT(%integer op,y,x) 1903 !Basic code planting procedure 1904 ! OP is an index to the array defining op-codes 1905 ! (it can be flagged to force SIZE) 1906 ! For unary operations the operand is given by X (Y zero) 1907 ! For binary operations the operands are Y (source) and X (dest) 1908 %integer OPCODE,PC1,I,F,EXTWORD,INFO,KIND,MODE,MODEX,SIZE 1909 %record(identinfo)%name DX,DY 1910 %switch S(0:21) 1911 %constbytearray SIZESYM(0:3) = 'L','B','W','?' 1912 1913 %integer%fn NONLOCAL(%integer l) 1914 %integer r 1915 %result = mb %if l = outerlevel 1916 hold(l)_status = hold(l)_status!globbed %if l # level 1917 %result = f1 %if l = outerlevel+1 1918 r = maxareg 1919 %cycle 1920 %result = r %if c_reg_content(r) = d7+l; ![unique] 1921 r = r-1 1922 %repeat %until r < a0 1923 ![not good enough: 1. may need two 1924 ! 2. FREE updated elsewhere without regard to this] 1925 r = maxareg 1926 %while a0b<<(r-a0)&free = 0 %cycle 1927 fault(plexerr) %and %exit %if r = a0 1928 r = r-1 1929 %repeat 1930 c_reg_content(r) = d7+l 1931 dtsprel_mode = globalmode; dtsprel_val = l<<2 1932 plant(move,lablim+2,r) 1933 %result = r 1934 %end 1935 1936 %constinteger MOVEQ=36, ADDQ=37, MOVEA=39, C ADDA=40, ADDI=44 1938 1939 %if x > 0 %start 1940 intern(1) %and %return %if x >= explim 1941 dx == dict(x) 1942 modex = dx_mode 1943 %if modex >= framemode %and modex # c_mode %c C %and modex&2_111000 # 2_111000 %start 1945 modex = nonlocal(modex&7)-a0+(modex&(7<<3)) 1946 %finish 1947 %finish %else modex = litmode %and dx == dint 1948 %if y > 0 %start 1949 intern(1) %and %return %if y >= explim 1950 dy == dict(y) 1951 mode = dy_mode 1952 %if mode >= framemode %and mode # c_mode %c C %and mode&2_111000 # 2_111000 %start 1954 mode = nonlocal(mode&7)-a0+(mode&(7<<3)) 1955 %finish 1956 %finish %else mode = litmode %and dy == dint 1957 size = op>>8; op = op&255 1958 %if op = move %start 1959 %if modex&2_111000 = 0 %start; !D 1960 op = moveq %if y <= 0 %and y >= litmite %and size&3 = 0 1961 %finish %else %if modex&2_110000 = 0 %start; !A 1962 op = movea 1963 %finish 1964 %finish %else %if op <= cmp %start 1965 %if op < cmp %and y < 0 %and y >= litquick %and y&1 = 0 %c C %then op=op+(addq-add) {ADDQ,SUBQ} %c C %else %if modex&2_111000 = aregmode %c C %then op=op+(adda-add) {ADDA,SUBA,CMPA} %c C %else %if y <= 0 %c C %then op=op+(addi-add) {ADDI,SUBI,CMPI} 1971 %finish %else %if op <= eor %start 1972 op = op+(addi-add) %if y <= 0 {ANDI,ORI,EORI} 1973 %finish 1974 info = def(op+op-1) 1975 opcode = info>>16 1976 %if info&sized # 0 %start; !data size required 1977 size = 4 %if size = 0 1978 %if op = move %start 1979 %if size = 4 %start 1980 opcode = opcode+16_2000 1981 %finish %else %if size = 2 %start 1982 opcode = opcode+16_3000 1983 %else 1984 opcode = opcode+16_1000 1985 %finish 1986 %else 1987 %if size = 4 %start 1988 opcode = opcode+16_80 1989 %finish %else %if size = 2 %start 1990 opcode = opcode+16_40 1991 %finish 1992 %finish 1993 %finish %else %if info&asized # 0 %start; !areg size required 1994 fault(sizerr) %if size = 1 1995 %if op # movem %start 1996 %if size = 0 %start 1997 size = 4 %unless y <= 0 %and 0 = is short(litval(y)) 1998 %finish 1999 %if size = 4 %start 2000 %if op = movea %then opcode = opcode!!16_1000 %c C %else opcode = opcode+16_0100 2002 %finish 2003 %else; !MOVEM 2004 size = 4 %if size = 0 2005 opcode = opcode+16_0040 %if size = 4 2006 %finish 2007 %finish 2008 {?} %if control&codelist # 0 %and control&list # 0 %start 2009 {?} print line %if length(rep) >= 4 2010 {?} put sym(codeflag); spaces(4-length(rep)) 2011 {?} put opcode(op) 2012 {?} %if size # 0 %start 2013 {?} put sym('.') 2014 {?} put sym(sizesym(size&3)) 2015 {?} %finish 2016 {?} spaces(12-length(rep)) 2017 {?} %if info&(63<<6) # 0 %start 2018 {?} put operand(y) 2019 {?} put sym(',') %if info&63 # 0 2020 {?} %finish 2021 {?} put operand(x) %if info&63 # 0 2022 {?} spaces(33-length(rep)); put sym(':') 2023 {?} %finish 2024 2025 pc1 = pc; pflag(pc1) = c_shorts; !op-code word 2026 pc = pc+1 2027 croak("Code space exhausted") %if pc >= swpc-8 2028 kind = info>>6 2029 again: 2030 ->s(kind&31) 2031 s(0): 2032 next: 2033 kind = info 2034 %if kind # 0 %start 2035 dy == dx; y = x; mode = modex 2036 info = 0 2037 ->again 2038 %finish 2039 ! 2040 !$IF VAX 2041 { opcode = opcode!sign16 %if opcode&sign16 # 0 2042 !$FINISH 2043 prog(pc1) <- opcode 2044 {?} %if control&codelist # 0 %and control&list # 0 %start 2045 {?} %cycle 2046 {?} put sym(' ') 2047 {?} put hex(prog(pc1)) 2048 {?} pc1 = pc1+1 2049 {?} %repeat %until pc1 >= pc 2050 {?} print line 2051 {?} %finish 2052 %return 2053 2054 !Set flag value for PC-relative reference 2055 ! distinguishing GLOBAL (const access), INDIRECT GLOBAL (procedure), C ! and LOCAL (label) -- the last further distinguished according to 2057 ! whether the instruction permits shortening 2058 %routine PCREL(%integer shorten) 2059 %if dy_mode = labmode %start 2060 f = jump; f = longjump %if shorten = 0 2061 %if extword > 0 %start; !label defined 2062 %if shorten # 0 %and (extword-pflag(extword)-pc+c_shorts)<<1 >= -128 %start 2063 %if c_shorts = 255 %start 2064 zaps = zaps+100 2065 %else 2066 shorts = shorts+1; c_shorts = c_shorts+1 2067 f = shortjump 2068 %finish 2069 %finish 2070 %else 2071 extword = -extword 2072 dy_val = -pc 2073 %finish 2074 %finish %else %if dy_mode = procmode %start; !procedure 2075 f = indglobal; extword = y; !rather than DY_VAL 2076 %finish %else %if dy_mode = constmode %start; !constant data ref 2077 f = global 2078 f = f+1 %if extword < 0 2079 f = f+2 %if extword > 65535 2080 %finish %else %if dy_mode # pcmode %start 2081 fault(moperr) 2082 %finish 2083 %end 2084 2085 s(qea): !LEA 2086 -> ea0 %unless mode&63 = x-(a0-indexmode) %and dy_val&255 = 0 2087 ! LEA 0(Ax,Dy) => ADDA Dy,Ax 2088 opcode = 16_D1C0+dy_val>>12&15 2089 -> next 2090 2091 s(wea): 2092 dy_flags = dy_flags!(mflag!wflag) 2093 -> wea1 2094 s(rwea): ![for our purposes, read&write counts as neither] 2095 dy_flags = dy_flags!mflag 2096 wea1: 2097 -> err %if y <= 0 %or mode&63 >= pcmode 2098 -> ea1 2099 s(revea): !reversible cases (EA,REG or REG,EA) 2100 %if modex&2_111000 # 0 %start; !dest not D 2101 kind = shift; info = rwea 2102 opcode = opcode!!16_0100 2103 ->sreg 2104 %finish 2105 s(ea): ea0: 2106 %if y <= 0 %start 2107 opcode = opcode+litmode; !immediate 2108 ->simm 2109 %finish 2110 %if dy_flags&(ext+spec+rflag+wflag) = ext+spec %c C %and dy_flags&proc # 0 %start 2112 ! Create transfer vector for external procedure 2113 fill own(1) %if ownad&1 # 0 2114 dy_val = ownad 2115 set own word(16_207C+(mb-a0)<<9); !MOVE.L #xxxxxxxx,MB 2116 set own word(0); set own word(0) 2117 set own word(16_4EF9); !JMP xxxxxxxx 2118 set own word(0); set own word(0) 2119 %finish 2120 %if (op = lea %or op = pea) %and mode&63 # pcmode %start 2121 !taking address: might read or write 2122 dy_flags = dy_flags!(mflag+rflag+wflag) 2123 ->err %if mode&2_111000 < aregmode+indir 2124 %else 2125 dy_flags = dy_flags!(mflag+rflag) 2126 %finish 2127 ea1: 2128 extword = dy_val 2129 %if mode = c_mode %start; !local 2130 mode = dispmode+7; extword = extword-c_sp; !convert to use SP 2131 %if extword < 0 %start 2132 intern(4) %if extword < -4 2133 mode = aregmode+pre+7 2134 extend stack(-extword) 2135 extword = 0 2136 %finish 2137 %finish 2138 mode = mode&63; !strip extra flags 2139 %if mode >= dispmode %start; !+extra 2140 f = 0 2141 %if mode = pcmode %start 2142 pcrel(0) 2143 %finish 2144 %if mode <= dispmode+7 %start 2145 %if extword = 0 %start 2146 ! Premode (just created) or Dispmode (=>Indmode) 2147 mode = mode+(aregmode+indir-dispmode) %if mode >= dispmode 2148 %else 2149 fault(dreacherr) %unless -32768 <= extword <= 32767 2150 store(extword,f) 2151 %finish 2152 %else 2153 mode = absmode+1 %if mode = absmode %and %not 0 = is short(extword) 2154 store(extword>>16,0) %if mode = absmode+1 2155 store(extword,f) 2156 %finish 2157 %finish 2158 mode = ((mode&7)<<3 + mode>>3)<<6 %if kind&shift # 0 2159 opcode = opcode+mode 2160 ->next 2161 2162 s(exreg&31): !EXG (D,D / A,A / D,A) 2163 %if mode&2_111000 = 0 %start; !D 2164 %if modex&2_111000 # 0 %start; !not D 2165 opcode = opcode!!16_C8; info = areg 2166 %finish 2167 -> sreg 2168 %finish 2169 opcode = opcode+8; info = areg 2170 -> sareg 2171 s(qpre): 2172 -> sreg %if mode&2_111000 = 0; !D 2173 opcode = opcode+8; info = preareg+shift 2174 s(preareg): 2175 mode = mode+(post-pre) 2176 s(postareg): 2177 mode = mode-post 2178 s(areg): sareg: 2179 mode = mode-8 2180 s(reg): sreg: 2181 -> err %unless mode&2_111000 = 0 2182 mode = mode&7 2183 mode = mode<<9 %if kind&shift # 0 2184 opcode = opcode+mode 2185 ->next 2186 2187 s(qreg): !Shift formats -- quick,Dx / Dy,Dx / 1, (W) 2188 opcode = opcode+16_20 %and ->sreg %if y > 0 2189 %if y = one %and size = 2 %and modex&2_111000 # 0 %start 2190 opcode = opcode!!16_290 2191 ->next 2192 %finish 2193 s(quick): 2194 -> err %if y >= 0 2195 y = litval(y) 2196 ->err %unless y <= 8 2197 opcode = opcode+(y&7)<<9; !(always aligned to bit9) 2198 ->next 2199 2200 s(tquick): !(TRAP) 2201 -> err %unless -30 <= y %and y&1 = 0; !{0<=}litval(y)<=15 2202 s(mquick): 2203 ->err %unless y <= 0 %and y >= litmite 2204 y = litval(y) 2205 opcode = opcode+y&255 2206 ->next 2207 s(rel): 2208 ->s(mquick) %if y <= 0 %and y >= litmite 2209 s(longrel): 2210 ->simm %if y <= 0 2211 dy_flags = dy_flags!rflag 2212 extword = dy_val 2213 f = 0 2214 pcrel(longrel-kind&31) 2215 store(extword,f) 2216 ->next 2217 2218 s(ireg): !immediate or reg 2219 ->sreg %if y > 0 2220 opcode = opcode!!16_900 2221 s(imm): 2222 ->err %if y > 0 2223 simm: 2224 y = litval(y) 2225 store(y>>16,0) %if size = 4 2226 put: 2227 store(y,0) 2228 ->next 2229 s(ximm): !MOVEM (IMM,EA or EA,IMM) 2230 %if y > 0 %start; !EA,IMM 2231 opcode = opcode!!16_0400 2232 i = x; x = y; y = i 2233 dx == dy; modex = mode 2234 %finish 2235 y = litval(y) 2236 %if prea0 <= x <= prea7 %start; !-(SP) 2237 i = 0; !Reverse bits 2238 i = i<<1+y&1 %and y = y>>1 %for extword = 1,1,16 2239 y = i 2240 %finish 2241 ->put 2242 s(data): 2243 -> err %if y <= 0 2244 -> err %if mode # absmode 2245 opcode = dy_val 2246 ->next 2247 err: 2248 fault(moperr) 2249 ->next 2250 %end; !plant 2251 2252 %routine PLANTLIT(%integer op,v,x) 2253 %if v >= 0 %start 2254 %if v > smallmax %then litstore(litmax) = v %and v = litmax %c C %else v = -(v<<1) 2256 %else 2257 %if v < smallmin %then litstore(litmax) = v %and v = litmax %c C %else v = v<<1+1 2259 %finish 2260 plant(op,v,x) 2261 %end 2262 2263 %routine PLANTLIT2(%integer op,y,v) 2264 %if v >= 0 %start 2265 %if v > smallmax %then litstore(litmax) = v %and v = litmax %c C %else v = -(v<<1) 2267 %else 2268 %if v < smallmin %then litstore(litmax) = v %and v = litmax %c C %else v = v<<1+1 2270 %finish 2271 plant(op,y,v) 2272 %end 2273 2274 %routine ALIGN(%integername AD, %integer size) 2275 !Impose alignment requirements on address AD for 2276 ! operand of length SIZE 2277 !provisional basis for bit addressing 2278 ! -- multiples of 16 on Word boundary 2279 ! -- multiples of 8 on Byte boundary 2280 ! -- other < 32 within one Longword 2281 !%constinteger BITMASK=16_E0000000 2282 ! %if size&7 = 0 %start 2283 ! ad = (ad&(\bitmask))+1 %if ad&bitmask # 0; !ensure on byte boundary 2284 ! %return %if size&8 # 0 2285 ! %else 2286 ! %return %if size < 16 2287 ! %return %if ad>>29+(ad&1)<<3+size <= 32 2288 ! ad = (ad&(\bitmask))+1 %if ad&bitmask # 0 2289 ! %finish 2290 ad = ad+1 %if size # 1 %and ad&1 # 0 2291 %end 2292 2293 %routine ADDIMM(%integer bytes,dest) 2294 %if bytes <= 0 %start 2295 %return %if bytes = 0 2296 %if bytes >= -8 %start 2297 plantlit(sub,-bytes,dest) 2298 %return 2299 %finish 2300 %finish %else %if bytes <= 8 %start 2301 plantlit(add,bytes,dest) 2302 %return 2303 %finish 2304 %if a0 <= dest <= a7 %and 0 = is short(bytes) %start 2305 plant(lea,tempd(dest,bytes),dest) 2306 %return 2307 %finish 2308 plantlit(add,bytes,dest) 2309 %end 2310 2311 %integer%fn FREE REG(%integer rset) 2312 %integer r,r1 2313 r = d0; rset = rset&free 2314 %if rset = 0 %then fault(plexerr) %else %start 2315 r = r+1 %and rset = rset>>1 %while rset&1 = 0 2316 r1 = r 2317 %while c_reg_content(r) # undef %cycle 2318 r = r+1; rset = rset>>1 2319 r = r1 %and %exit %if rset = 0 2320 r = r+1 %and rset = rset>>1 %while rset&1 = 0 2321 %repeat 2322 free = free-d0b<<(r-d0) 2323 %finish 2324 %result = r 2325 %end 2326 2327 %routine MOVE BLOCK(%integer source,dest,bytes) 2328 !Generate code to move a fixed number of bytes 2329 ! from SOURCE (0,reg,pre,post) to DEST (pre,post) 2330 ! -- source & dest addresses both even if BYTES even 2331 %integer op,f,r,pc1 2332 op = move; op = clr %if source = 0 2333 %if bytes <= 16 %and bytes&1 = 0 %start 2334 plant(op,source,dest) %and bytes = bytes-4 %while bytes >= 4 2335 plant(op+2<<8,source,dest) %if bytes >= 2 2336 %else; !use loop 2337 op = op+1<<8 2338 %if bytes&1 = 0 %start 2339 bytes = bytes>>1; op = op+1<<8; !.B -> .W 2340 %if bytes&1 = 0 %start 2341 bytes = bytes>>1; op = op+2<<8; !.W -> .L 2342 %finish 2343 %finish 2344 f = free 2345 %if bytes <= 32768 %and free&anydreg # 0 %start 2346 r = free reg(anydreg) 2347 plantlit(move,bytes-1,r) 2348 pc1 = pc 2349 plant(op,source,dest) 2350 plantlit2(dbra,r,(pc1-pc-1)<<1) 2351 bytes = undef 2352 %else 2353 r = free reg(anydreg!bregb) 2354 plantlit(move,bytes,r) 2355 pc1 = pc 2356 plant(op,source,dest) 2357 plant(sub,one,r) 2358 plantlit2(bne,0,(pc1-pc-1)<<1) 2359 bytes = 0 2360 %finish 2361 c_reg_content(r) = bytes; free = f 2362 %finish 2363 %end 2364 2365 %routine UPDATE SP 2366 %return %if c_val = 0 2367 %if c_val < 0 %start 2368 addimm(-c_val,a7); c_sp = c_sp-c_val 2369 %else 2370 %if control&assmask = 0 %then addimm(-c_val,a7) {no unass check} %c C %else move block(d7,prea7,c_val) 2372 extend stack(c_val) 2373 %finish 2374 c_val = 0 2375 %end 2376 2377 %routine GET BOUNDS(%integer t,%integername lo,hi) 2378 ![Note: sets HI after LO -- see dummy params in VALOK] 2379 %if dict(t)_type = t # inttype %start; !basetype 2380 lo = 0; hi = dict(t)_size 2381 %else 2382 %if dict(t+1)_mode # litmode %then lo = minint %c C %else lo = dict(t+1)_val 2384 %if dict(t+2)_mode # litmode %then hi = maxint %c C %else hi = dict(t+2)_val 2386 %finish 2387 %end 2388 2389 %integer%fn SIZE(%integer t) 2390 !Storage size for given object type in bytes 2391 ! > 0 for operand passable in register 2392 ! < 0 otherwise 2393 %integer s,ss,lo,hi 2394 %record(identinfo)%name tp 2395 tp == dict(t) 2396 %if tp_flags&nonord = 0 %start 2397 %result = tp_size %if tp_type # t; !subrange 2398 %result = 4 %if tp_type = inttype 2399 %result = 1 %if tp_size <= 255 2400 %result = 2 2401 %finish 2402 %result = tp_val %if tp_flags&cat = recy 2403 %result = tp_size %if tp_flags&cat # arry 2404 %result = 0 %if tp_mode >= framemode; !dynamic bounds 2405 s = 4; s = size(tp_type) %if tp_flags >= 0 2406 get bounds(tp_xtype,lo,hi) 2407 %result = 0 %if lo = minint %or hi = maxint 2408 ss = (hi-lo+1)*s 2409 %result = ss %if ss <= 0 2410 %if s = 1 %start; !byte element size (not nec aligned) 2411 %result = ss %if ss = 1 2412 %else; !word,long element size (aligned) 2413 %result = ss %if ss <= 4 2414 %finish 2415 %result = -ss 2416 %end 2417 2418 %integer%fn NSIZE(%record(identinfo)%name dp) 2419 %result = 4 %if dp_flags&(name+indirect) # 0 2420 %result = 0 %if dp_flags&proc # 0; ![??] 2421 %result = size(dp_type) 2422 %end 2423 2424 %integer%fn TSIZE(%integer t) 2425 %result = size(dict(t)_type) 2426 %end 2427 2428 %routine FORGET(%integer r) 2429 c_reg_content(r) = undef 2430 %end 2431 %routine FORGET CC 2432 c_reg_ccy = undef 2433 %end 2434 %routine FORGET REGS 2435 %shortname cc 2436 cc==c_reg_content(maxareg) 2437 %cycle 2438 cc = undef 2439 %exit %if cc == c_reg_content(d0) 2440 {cc == cc[-1]}%exit {GT: Need to rewrite in standard imp} 2441 %repeat 2442 c_reg_ccy = undef; c_reg_line = -9 2443 %end 2444 %routine FORGET TRIPLES 2445 litpos = litmin; explo = explim; oldexplo = explim 2446 %end 2447 %routine FORGET ALL 2448 %integer i,j 2449 %record(contentinfo)%name lr 2450 forget regs 2451 j = dictlim 2452 %cycle 2453 j = j+1 2454 %exit %if j >= curlab 2455 lr == lreg(j-dictlim) 2456 lr_content(i) = undef %for i = d0,1,maxareg 2457 lr_ccx = undef 2458 %repeat 2459 forget triples 2460 %end 2461 2462 %routine DEFINE JUMPS(%integer chain) 2463 %integer i,j,k 2464 chain = -chain 2465 %return %if chain <= 0; !no jumps to this label 2466 c_forward = c_forward-1; c_access = 1 2467 %cycle 2468 i = prog(chain) 2469 %if pflag(chain) = jump %start; !shortenable 2470 j = chain-pflag(chain-1); !adjusted jump position 2471 k = (pc-c_shorts-j)<<1; !displacement 2472 %if k > 2 %and k <= 127 %start 2473 %if c_shorts = 255 %start 2474 zaps = zaps+100 2475 %else 2476 c_shorts = c_shorts+1; shorts = shorts+1 2477 pflag(chain) = shortjump 2478 j = chain 2479 %cycle 2480 pflag(j) = pflag(j)+1 %if pflag(j) >= zeroshorts 2481 j = j+1 2482 %repeat %until j = pc 2483 %finish 2484 %finish 2485 %finish 2486 prog(chain) = pc 2487 chain = i 2488 %repeat %until chain <= 0 2489 %end 2490 2491 %routine SAVE CONTEXT(%integer l) 2492 !Store register content associated with label L 2493 ! (prior to generating forward branch) 2494 %integer r 2495 %record(contentinfo)%name lr 2496 %return %if l-dictlim < 0 {user label} 2497 lr == lreg(l-dictlim) 2498 %if dict(l)_val >= 0 %start; !first jump to this label 2499 dict(l)_val = 0 2500 lr = c_reg 2501 c_forward = c_forward+1 2502 %else 2503 %for r = d0,1,maxareg %cycle 2504 lr_content(r) = undef %if lr_content(r) # c_reg_content(r) 2505 %repeat 2506 lr_ccy = undef %if lr_ccx # c_reg_ccx %or lr_ccy # c_reg_ccy 2507 lr_line = -9 %if lr_line # c_reg_line 2508 %finish 2509 %end 2510 2511 %routine SRCALL(%integer x) 2512 %routine PUT PRIM(%record(identinfo)%name DX) 2513 !<>16&511; limit = start+dx_val&255 2579 dx_val = cad+dx_val>>7&(255<<1); !entry 2580 dx_mode = procmode 2581 %if start = limit %start; !range check 2582 ddx == dict(check) 2583 put prim(ddx) %and dx_val = cad %if ddx_mode = absmode 2584 set code word(16_0C80); !CMPI.L #?,D0 2585 set code longword(dict(x+1)_val); !lower 2586 set code word(16_6D00); !BLT 2587 set code word(ddx_val-cad) 2588 set code word(16_0C80); !CMPI.L #?,D0 2589 set code longword(dict(x+2)_val); !upper 2590 set code word(16_6E00); !BGT 2591 set code word(ddx_val-cad) 2592 set code word(16_4E75); !RTS 2593 %else 2594 set code word(primcode(start)) %and start=start+1 %until start >= limit 2595 %finish 2596 %end 2597 2598 %record(identinfo)%name dx,tp 2599 dx==dict(x); tp==typecell(dx_type) 2600 %if dx_mode = absmode %and dx_val < 0 %start; !prim routine 2601 ![**for now**: the convention is inadequate because excludes abs neg] 2602 put prim(dx) 2603 %else 2604 c_status = c_status!unknown %if tp_val <= 0 2605 c_totstack = c_sp-imod(tp_val) %if c_sp-imod(tp_val) < c_totstack 2606 %finish 2607 %if dx_mode&63 = pcmode %start; !internal 2608 c_forward = c_forward+1 %if dx_flags&spec # 0 %and dx_flags&rflag = 0 2609 plant(bsr,0,x) 2610 %finish %else %if dx_flags&(name+indirect) = 0 %or dx_flags&ext # 0 {temp} %start 2611 plant(jsr,0,x) 2612 %finish %else %if free&a0b<<3 # 0 %start 2613 plant(move,x,a0+3) 2614 plant(jsr,0,a0+3+indir) 2615 forget(a0+3) 2616 %else 2617 plant(move,x,tempd(a7,-4)) 2618 plantlit(move,16_4EF9,tempd(a7,-6)) 2619 plant(jsr,0,lablim) 2620 %finish 2621 %end; !srcall 2622 ! 2623 %routine DEFINE LABEL(%integer lab) 2624 %integer r,chain 2625 %record(contentinfo)%name lr 2626 chain = dict(lab)_val 2627 %if chain >= 0 %start; !label before jumps 2628 update sp 2629 forget regs 2630 %else 2631 lr == lreg(lab-dictlim) 2632 %if c_access = 0 %start; !no fall-through 2633 c_reg = lr; !so just incoming context 2634 %else; !join 2635 %for r = d0,1,maxareg %cycle 2636 forget(r) %if c_reg_content(r) # lr_content(r) 2637 %repeat 2638 forget cc %if c_reg_ccx # lr_ccx %or c_reg_ccy # lr_ccy 2639 c_reg_line = -9 %if lr_line # c_reg_line 2640 %finish 2641 %finish 2642 define jumps(chain) 2643 dict(lab)_val = pc 2644 {?} put operand(lab) %if control&codelist # 0 %and control&list # 0 2645 %end; !define label 2646 2647 %routine SET USER LABEL(%integername chain) 2648 update sp 2649 addimm(c_temps,a7) %if c_temps # 0 %and c_access # 0 {remove temps} 2650 define jumps(chain) 2651 chain = pc 2652 c_access = 1; !anyway 2653 addimm(-c_temps,a7) %if c_temps # 0 {restore temps} 2654 forget regs 2655 forget triples %if curlab = c_lab1 2656 %end 2657 2658 %routine FLUSH 2659 %if pendcond < 0 %start; !indicator for line num update 2660 litstore(litpos) = line 2661 %if control&tracebit # 0 %then plantlit2(trapi,litpos,15) %c C %else %if line-c_reg_line > 8 %then plant(move+2<<8,litpos,lineloc) %c C %else plantlit(add+2<<8,line-c_reg_line,lineloc) 2664 forget cc; c_reg_line = line 2665 %else 2666 %if pendout # 0 %start 2667 pendcond = pendcond&15 2668 c_access = 0 %if pendcond = 0 2669 %if pendcond # 1 %start 2670 save context(pendout) 2671 plant(bra+pendcond,0,pendout) 2672 %finish 2673 %finish 2674 define label(pendin) %if pendin # 0 2675 %finish 2676 pendcond = 0 2677 %end 2678 2679 !!!!!!!!!!!!!!!! Main code generation procedure !!!!!!!!!!!!!!!!!!!!! 2680 2681 %constinteger INST=1<<30 2682 2683 %routine EVAL(%integername pp, %integer rset) 2684 !Evaluate the operand identified by PP as defined by RSET: 2685 ! RSET = boolean vector of acceptable registers 2686 ! + SIGN to indicate that stopping at EA is acceptable 2687 ! + 1<<16 to indicate byte value ok 2688 ! + 2<<16 to indicate short value ok 2689 ! + STACK if stack ok [not yet: too complex] 2690 %constinteger ASL=32, C CMPM=43, C TRAPV=70, C SWAP=74, EXTL=76, C JMP=57, TST=59, DBNE=86 2695 2696 %constinteger MOVEW=move+2<<8, ADDW=add+2<<8, C MOVEB=move+1<<8, ADDB=add+1<<8, C SUBB=sub+1<<8, CMPB=cmp+1<<8, C CMPMB=cmpm+1<<8 2700 2701 %constinteger VAL=sign+anyreg, REF=sign, C SIZESHIFT=16, C TOBYTE=1<<16, TOSHORT=1<<17, {1<<18 not sig} C TOSTACK=1<<19, ASAD=1<<20 2705 2706 %switch DO(0:opmax) 2707 %owninteger STSIZ=0; !this variable is used to convey a 2708 !rarely required 3rd parameter to EVAL 2709 !Its value is captured into STSIZE on entry 2710 !A negative value indicates a string; 2711 ! a positive value a fixed length structure 2712 ! * CF normal use of negative/positive size * 2713 %integer I,J,P,ACT,X,Y,XX,YY,WX,WY,SX,SY,R,OLDFREE,FREED 2714 %integer M,V,SP,STSIZE,OP,CASE 2715 %record(identinfo)%name DP,DX,DY,TX 2716 2717 %integer%fn FREE DREG 2718 %result = free reg(anydreg) 2719 %end 2720 2721 %integer%fn FREE AREG(%integer content) 2722 %integer r 2723 r = free reg(anyareg) 2724 c_reg_content(r) = content 2725 %result = r 2726 %end 2727 2728 %routine PUSH(%integer x) 2729 plant(move,x,prea7); extend stack(4) 2730 %end 2731 %routine POP(%integer x) 2732 plant(move,posta7,x); c_sp = c_sp+4 2733 %end 2734 %routine PUSHS(%integer x,s) 2735 plant(move+s<<8,x,prea7) 2736 %if s < 4 %then extend stack(2) %else extend stack(4) 2737 %end 2738 2739 %routine PUSH BLOCK(%integer areg,bytes) 2740 %if bytes <= 4 %then move block(areg+indir,prea7,bytes) %c C %else addimm(bytes,areg) %and move block(areg+pre,prea7,bytes) 2742 extend stack(bytes) 2743 %end 2744 2745 %routine COMPILE UNCOND BRANCH(%integer l) 2746 %if pendcond # 0 %start 2747 %if pendcond < 0 %start 2748 pendcond = 0; !ok? 2749 %finish %else %if pendin # 0 %start 2750 flush; ![safe - improvable?] 2751 %else 2752 pendcond = pendcond!!1 2753 c_access = -2 %if pp+1 < np %and dict(pp+1)_act = else 2754 %finish 2755 %finish 2756 pendcond = pendcond&15 2757 c_access = 0 %if pendcond = 0 2758 plant(bra+pendcond,0,l) %if pendcond # 1 2759 pendcond = 0 2760 %end 2761 2762 %integer%fn CLEAN REG 2763 %integer r 2764 free = free-bregb %and %result = breg %if free&bregb # 0 2765 r = free dreg 2766 plant(clr,0,r) 2767 %result = r 2768 %end 2769 2770 %integer%fn WEIGHT(%integer p) 2771 !(Heuristic: can't anticipate all generation decisions) 2772 %integer a,wy 2773 %record(identinfo)%name dp 2774 p = p-ad %if p >= explim 2775 %result = 1 %if p < np0 2776 dp == dict(p) 2777 a = dp_act 2778 %result = 999 %if a >= imul; !funcall,mapcall 2779 wy = weight(dp_y) 2780 %result = wy %if wy >= 999 2781 wy = wy-1 %if a = recref %and dict(dp_x)_flags >= 0 2782 %result = wy+weight(dp_x) 2783 %end 2784 2785 %routine CHECK ADDRESS(%integer v) 2786 %if a0 <= v <= a7 %then plant(cmp+2<<8,0,v) %else plant(tst,0,v) 2787 srcall(adok) 2788 forget cc 2789 %end 2790 2791 !!!!!!!!!!!!!!!!!!! Procedure call !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2792 ! 2793 ! _____ACT_________X__________Y____ 2794 ! P -> | procident | param 1 | param 2 | 2795 ! | 0 | param 3 | param 4 | 2796 ! . . . . 2797 ! 2798 %routine CALL 2799 !Load parameters following P and call procedure ACT (DX) 2800 ! Update PP for RCALL 2801 %integer sp,stage,maxq,awkward 2802 2803 %routine EVAL PARLIST(%integer arg,q) 2804 %record(identinfo)%name darg,dv 2805 %integer v,w,f,r,s 2806 !Stage 0 (forward): 2807 !Stage 0 (returning): 2808 !Stage 1 (forward): 2809 !Stage 1 (returning): 2810 %return %if arg = 0 2811 darg == dict(arg) 2812 q = q+1; maxq = q %if q > maxq 2813 %if q&1 = 0 %then v = dict(p+q>>1)_x %else v = dict(p+q>>1)_y 2814 r = darg_reg&15 2815 s = size(darg_type) 2816 %if darg_flags&proc # 0 %start 2817 s = 0 2818 %if awkward # 0 %start 2819 f = v; f = f-ad %if f >= explim 2820 dv == dict(f) 2821 %if dv_flags&(ext+spec) # ext+spec %start 2822 !non-external to (maybe) external 2823 eval parlist(darg_link,q) %and %return %if stage # 0 2824 %if dv_flags&(name+indirect) # 0 %then plant(move,f,prea7) %C C %else plant(pea,0,f) 2826 plantlit(move+2<<8,16_4EF9,prea7) {JMP entry} 2827 plant(move,mb,prea7) 2828 plantlit(move+2<<8,16_287C,prea7) {MOVE #xxxx,mb} 2829 extend stack(12) 2830 s = c_sp 2831 eval parlist(darg_link,q) 2832 %if darg_val > 0 %start 2833 plant(pea,0,temp(c_mode,s)) 2834 %else 2835 plant(lea,temp(c_mode,s),r+d0) 2836 free = free&(\(d0b< 0 %start; !passed on stack 2843 eval parlist(darg_link,q) 2844 %return %if stage # 0 2845 %if darg_flags < 0 %start; !name 2846 f = free 2847 ! eval(v,ref) 2848 ! plant(pea,0,v); extend stack(4) 2849 eval(v,anyareg) 2850 push(v) 2851 free = f 2852 %return 2853 %finish 2854 %if s > 0 %start; !simple value 2855 f = free; eval(v,val) 2856 pushs(v,s) 2857 free = f 2858 %else; !structure by value 2859 stsiz = s 2860 stsiz = -stsiz %if category(darg_type) # stringy 2861 eval(v,tostack) 2862 %finish 2863 %return 2864 %finish 2865 %if s <= 0 %and darg_flags >= 0 %start 2866 !structure by value -- ad in reg 2867 v = v-ad %if v >= explim 2868 %if v >= np0 %start 2869 dv == dict(v) 2870 %if dv_act >= concat %and dv_mode = 0 %start 2871 !string/record function 2872 %if stage = 0 %start 2873 stsiz = s 2874 stsiz = -stsiz %if category(darg_type) # stringy 2875 r = v; eval(r,tostack); free = free!a0b; ![?here?] 2876 c_reg_content(a0) = v+ad 2877 dv_val = c_sp 2878 eval parlist(darg_link,q) 2879 %else 2880 eval parlist(darg_link,q) 2881 %if c_reg_content(r+d0) # v+ad %start 2882 dv_mode = c_mode 2883 plant(lea,v,r+d0) 2884 dv_mode = 0 2885 %finish 2886 free = free&(\(d0b<= 999 %start 2895 eval parlist(darg_link,q) 2896 %return %if stage # 0 2897 %else 2898 %if w >= 2 %and stage # 0 %start 2899 eval(v,d0b<>1 %if p < np; !update for RCALL + RESOL 2924 forget regs 2925 c_reg_line = line %if dx_flags&(ext+proc) = ext+proc1; !%system 2926 %end; !call 2927 ! 2928 %routine STRUCTCALL(%integer entry,size) 2929 size = mite(-size-1) %and forget(breg) %if size <= 0; !string 2930 plantlit(move,size,d0) 2931 srcall(entry) 2932 forget(d0) 2933 %end 2934 2935 %routine PUSH STRUCTURE 2936 %if stsize <= 0 %start; !string 2937 structcall(strtostk,stsize) 2938 forget(a0); forget(a1); forget(a0+2) 2939 extend stack(256-(stsize&254)) 2940 %else; !fixed size structure 2941 push block(a0,(stsize+1)&(\1)) 2942 %finish 2943 %end 2944 2945 %routine OK REG(%integer got) 2946 r = got 2947 %if d0b<<(got-d0)&rset = 0 %start 2948 c_reg_content(got) = pp 2949 %if rset&free = 0 %and rset&tostack # 0 %start 2950 push structure; r = a7 2951 ! push(got); r = a7 2952 ! c_reg_ccx = pp; c_reg_ccy = 0 2953 %else 2954 r = free reg(rset&(\bregb)); plant(move,got,r) 2955 c_reg_ccx = pp %and c_reg_ccy = 0 %if r < a0 2956 %finish 2957 %finish 2958 %end 2959 2960 %routine OK AREG(%integer got,ok) 2961 r = got 2962 %if a0b<<(got-a0)&ok = 0 %start 2963 r = free reg(ok); plant(move,got,r) 2964 %finish 2965 %end 2966 2967 %routine LOAD ADDRESS(%integer p) 2968 %integer i,f 2969 %if rset&anyareg&free # 0 %start 2970 %if dp_mode&2_111000 = indexmode %and dp_val&255 = 0 %start 2971 i = a0b<<(dp_mode&7) 2972 rset = i %if rset&free&i # 0 2973 %finish 2974 r = free reg(rset&anyareg) 2975 plant(lea,p,r) 2976 %else 2977 f = free 2978 i = free areg(p+ad); plant(lea,p,i) 2979 free = f 2980 r = free reg(rset&(\bregb)); plant(move,i,r) 2981 %finish 2982 %end 2983 2984 %routine COMMANDEER(%integer regs) 2985 %integer r 2986 freed = \free®s 2987 %if freed # 0 %start 2988 regs = freed; r = d0 2989 %while regs # 0 %cycle 2990 push(r) %and forget cc %if regs&1 # 0 2991 regs = regs>>1; r = r+1 2992 %repeat 2993 free = free!freed; rset = rset&(\freed) 2994 %finish 2995 %end 2996 %routine RESTORE(%integer regs) 2997 %integer r 2998 r = a7 2999 %while regs # 0 %cycle 3000 %if regs&16_8000 # 0 %start 3001 pop(r); forget(r); !*should have remembered it* 3002 forget cc 3003 %finish 3004 regs = regs<<1&16_FFFF; r = r-1 3005 %repeat 3006 %end 3007 3008 %routine PARTREG 3009 ! Something smaller than integer has been loaded to R 3010 ! Determine what else to do (using SX,SY) 3011 sy = 4 %if r = breg %or r >= a0 3012 %while imod(sy) < sx %cycle 3013 %if sy > 0 %start; !signed 3014 plant(extl-2+sy,0,r); !ext.w,ext.l 3015 sy = sy+sy 3016 %else 3017 %if sy = -1 %start; !unsigned byte 3018 plantlit(and,255,r) 3019 %else; !unsigned word (half) 3020 plantlit(and,16_FFFF,r) 3021 %finish 3022 sy = 4 3023 %finish 3024 %repeat 3025 %end 3026 3027 !!Start of EVAL 3028 3029 stsize = stsiz; !additional parameter (for TOSTACK cases) 3030 rset = rset&(\anyareg) %if rset&tobyte # 0; ![1 bit] 3031 p = pp; p = p-ad %if p >= explim 3032 rset = rset-asad %and pp = p+ad %if rset&asad # 0 3033 %if p <= 0 %then dp == dint %else dp == dict(p) 3034 oldfree = free; freed = 0 3035 3036 %if rset # inst %start 3037 %unless dp_mode&2_110000 = 0 %and pp < np0 %start; !not already reg 3038 j = pp 3039 %if rset&(anydreg!bregb{+tostack}) # 0 %start; !data reg acceptable 3040 i = d0 3041 %cycle; !See if available 3042 j = i %and %exit %if c_reg_content(i) = j 3043 i = i+1; i = a0 %if i = maxdreg+1 3044 %repeat %until i > maxareg 3045 %finish %else %if rset&anyareg # 0 %start; !try address regs first 3046 i = maxareg 3047 %cycle 3048 j = i %and %exit %if c_reg_content(i) = j 3049 i = i-1; i = maxdreg %if i = a0-1 3050 %repeat %until i < d0 3051 %finish %else %if j < explim %and rset # tostack %start; !REF: try for address 3052 i = a0 3053 %cycle 3054 %if c_reg_content(i) = j+ad %start 3055 free = free&(\(a0b<<(i-a0))) 3056 dp_flags = dp_flags!(rflag+wflag) 3057 pp = i+indir 3058 %return 3059 %finish 3060 i = i+1 3061 %repeat %until i > maxareg 3062 %finish 3063 %else; !already reg 3064 j = dp_mode+d0; !in case reg alias 3065 %if rset < 0 %start; !EA ok means any reg ok 3066 pp = j 3067 %return 3068 %finish 3069 pp = c_reg_content(j); !fiddle for update 3070 %finish 3071 3072 %if 0 < j <= a7 %start; !operand (now) in reg 3073 ok reg(j) 3074 dp_flags = dp_flags!rflag 3075 -> endload 3076 %finish 3077 3078 %if p <= 0 %start; !literal 3079 %return %if rset < 0 3080 %if rset = tostack %start 3081 i = constmode; i = pcmode %if p = 0; !null string [sneaky] 3082 plant(lea,temp(i,litval(p)),a0); !A0 must be free 3083 forget(a0) 3084 push structure 3085 %return 3086 %finish 3087 %if pp < explim %start; !normal value 3088 rset = rset&(\bregb) %if p < -(255<<1) %or p&1 # 0; !0:255 ok 3089 r = free reg(rset) 3090 %if r < a0 %or p # 0 %then plant(move,p,r) %c C %else plant(sub,r,r) 3092 %else; !address within FINAL 3093 i = constmode; i = pcmode %if p = 0; !null string [sneaky] 3094 load address(temp(i,litval(p))) 3095 %finish 3096 c_reg_ccx = pp %and c_reg_ccy = 0 %if r < a0 3097 ->endload 3098 %finish 3099 %finish 3100 %if p >= np0 %start; !complex 3101 more: 3102 act = dp_act; x = dp_x; y = dp_y 3103 xx = x; yy = y 3104 -> proccall %if act > opmax 3105 -> do(act) 3106 %finish 3107 3108 do(move): 3109 load: 3110 i = 0 3111 i = i+1 %if dp_flags&indirect # 0 3112 i = i+2 %if dp_flags < 0 3113 %if pp >= explim %start {address wanted} 3114 %if i = 0 %start 3115 free = oldfree 3116 load address(p) 3117 %else 3118 %if i = 3 %start; !indirect name 3119 free = oldfree 3120 r = free areg(undef); plant(move,p,r) 3121 p = r+indir 3122 %finish 3123 pp = p %and %return %if rset < 0 3124 free = oldfree 3125 r = free reg(rset); plant(move,p,r) 3126 %finish 3127 c_reg_ccx = pp %and c_reg_ccy = 0 %if r < a0 3128 %else 3129 %if i > 0 %start 3130 free = oldfree 3131 r = maxareg+1 3132 %cycle 3133 r = r-1 3134 %if r < a0 %start 3135 r = free areg(p+ad); plant(move,p,r) 3136 plant(move,r+indir,r) %if i = 3 3137 check address(r) %if i > 1 %and control&assbit # 0 3138 %finish 3139 %repeat %until c_reg_content(r) = p+ad 3140 free = free&(\(a0b<<(r-a0))) 3141 p = r+indir 3142 %finish 3143 pp = p %and %return %if rset = ref 3144 sx = rset>>sizeshift&3; sx = 4 %if sx = 0 3145 i = dp_flags 3146 sy = size(dp_type) 3147 %if c_localdpos <= p < dictlim %and i&okflag = 0 %and c_forward = 0 %start 3148 !local, simple, always accessed 3149 %if i&wflag = 0 %start; !unassigned 3150 report(asserr+warn,p,0) %if c_faults = 0 3151 %finish 3152 dp_flags = dp_flags+okflag %if dp_flags >= 0 %and sy > 0 3153 %finish 3154 %if rset = tostack %start 3155 free = oldfree 3156 plant(lea,p,a0); !A0 must be free 3157 forget(a0) 3158 push structure 3159 %return 3160 %finish 3161 intern(5) %and %return %if sy <= 0 3162 i = i!okflag %if control&bassbit>>1<= 0 %start 3204 plant(cmp+i<<8,r,d7); !check unassigned 3205 srcall(unass) 3206 forget cc 3207 %finish 3208 %if sy # 4 %and r # breg %start; !not full reg 3209 forget(r) 3210 -> endload1 3211 %finish 3212 %finish 3213 endload: 3214 c_reg_content(r) = pp 3215 endload1: 3216 free = free&(\(d0b<<(r-d0))) 3217 r = r+indir %if rset = ref 3218 pp = r 3219 %return 3220 3221 dataload: 3222 eval(p,anydreg) 3223 ok reg(p) 3224 -> endload 3225 3226 !!!!!!!!!!!!!!!! Array / Record / Map !!!!!!!!!!!!!!!!!! 3227 3228 %integer%fn FREEISH AREG(%integer for) 3229 !Use the register component of M if alterable 3230 ! to avoid excessive dissipation of address registers 3231 %integer i 3232 i = m&7 3233 %result = free areg(for) %if a0b<= framemode 3234 free = free&(\(a0b< {index,ARRAY,SUBSCRIPT} 3297 ! ARRAY => ARRID 3298 ! or {index,ARRAY,SUBSCRIPT} 3299 ! or {recref,RECORD,ARRAY} 3300 ! TYPE INFO : TYPE = ELTYPE, XTYPE = INDEX-TYPE 3301 ! MODE,VAL = DOPE ADDRESS 3302 dx == dict(x) 3303 i = dx_type; !array type cell 3304 tx == dict(i) 3305 get bounds(tx_xtype,sx,sy) 3306 !establish multiplier (element size) 3307 m = imod(nsize(tx)) 3308 !ARRFLAG is set for either ABC requested or dynamic 3309 %if dx_flags&arrflag # 0 %and (y > 0 %or sx = minint %or m = 0) %start 3310 commandeer(d0b+d1b+a0b); ![D1 ??] 3311 ! subscript 3312 eval(y,d0b) 3313 ! dope vector 3314 j = 0 3315 j = j+12 %and i = i+1 %and tx == dict(i) %while tx_mode = 0 3316 %if tx_flags&indirect # 0 %start 3317 plant(move,i,a0) 3318 addimm(j,a0) %if j # 0 3319 %else 3320 %if tx_val = 0 %and tx_mode = constmode %start 3321 ! dope info not yet created 3322 fill code(1) %if cad&1 # 0 3323 tx_val = cad 3324 set code longword(sy) 3325 set code longword(sx) 3326 set code longword(m) 3327 %finish 3328 plant(lea,i,a0) 3329 %finish 3330 srcall(index) 3331 forget(d0); forget(a0) 3332 restore(freed&(\d0b)) 3333 free = oldfree&(\d0b) 3334 freed = freed&d0b 3335 i = x; eval(i,anyareg&free+asad) 3336 plant(add,d0,i) 3337 %if dp_flags < 0 %then forget(i) {ad of ad of P} %c C %else c_reg_content(i) = p+ad 3339 free = free!d0b %if freed = 0 3340 restore(freed) 3341 m = i+(dispmode-a0); v = 0 3342 -> setflags 3343 %finish 3344 index1: 3345 !deal with subscript 3346 j = 0 3347 %if y <= 0 %start; !literal subscript 3348 j = litval(y); y = 0 3349 %finish 3350 %if y >= np0 %and dict(y)_act = add %c C %and dict(y)_y <= 0 %start; !Y => {add,exp,lit} 3352 j = litval(dict(y)_y); y = dict(y)_x 3353 %finish 3354 %if m > 1 %start 3355 %if y # 0 %start 3356 %if m&(m-1) # 0 %and m <= 32767 %and sy <= 32767 %and sx >= -32768 %start 3357 putexp(muls,y,litref(m),inttype) 3358 %else 3359 putexp(imul,y,litref(m),inttype) 3360 %finish 3361 y = item 3362 %finish 3363 %finish 3364 %if dx_flags&(name+ext+arrflag+indirect) = indirect %and sx # 0 %start 3365 dx_val = dx_val+4; !0-based 3366 adeval(x,y,j*m) 3367 dx_val = dx_val-4 3368 %else 3369 j = j-sx; j = j*m %if m > 1 3370 adeval(x,y,j); !array,index,displacement 3371 %finish 3372 setflags: 3373 dx_flags = dx_flags!(mflag+wflag+rflag); !don't know 3374 setmode: 3375 ![what about FRAMEMODE?] 3376 %if dispmode <= m < indexmode %start 3377 %unless 0 = is short(v) %start 3378 ok areg(m+(a0-dispmode),oldfree&anyareg) 3379 addimm(v,r); forget(r) 3380 m = r-(a0-dispmode); v = 0 3381 %finish 3382 %if pp >= explim %and v = 0 %and rset # ref %and dp_flags >= 0 %start 3383 !address wanted, disp zero, as value, not name 3384 ! so the address is simply in the register 3385 ok reg(m+(a0-dispmode)) 3386 free = oldfree 3387 -> endload 3388 %finish 3389 %finish 3390 dp_mode = m; dp_val = v 3391 ->load 3392 3393 do(recref): 3394 ! P => {recref,RECORD,SUBEL} 3395 dx == dict(x) 3396 adeval(x,0,dict(y)_val); !record,subscript,displacement 3397 ->setflags 3398 3399 do(storemap): 3400 v = 0 3401 %if y >= explim %start 3402 y = y-ad; eval(y,ref) 3403 m = dict(y)_mode; v = dict(y)_val 3404 %else 3405 %if y >= np0 %start 3406 %if dict(y)_act = add %start 3407 m = dict(y)_y 3408 y = dict(y)_x %and v = litval(m) %if m <= 0 3409 ! eval(y,val) %if y >= dictlim 3410 %finish;! %else eval(y,val) 3411 %finish 3412 eval(y,anyareg) 3413 check address(y) %if control&assbit # 0 %and pp < explim 3414 m = y+(dispmode-a0) 3415 %finish 3416 -> setmode 3417 3418 do(lenref): 3419 do(sindex): 3420 x = x-ad %if x >= explim 3421 dx == dict(x) 3422 %if y <= 0 %then adeval(x,0,litval(y)) %c C %else eval(y,anydreg) %and adeval(x,y,0) 3424 -> setflags 3425 3426 do(dnew): 3427 commandeer(c_free) 3428 plant(move,y,d0) 3429 srcall(act) 3430 forget regs 3431 c_reg_line = line 3432 -> endmap 3433 3434 do(dtostring): 3435 proccall: 3436 dx == dict(act) 3437 -> rcall %if p < np 3438 -> funcall %if dx_flags&writable = 0 3439 !mapcall 3440 commandeer(c_free) 3441 call 3442 endmap: 3443 free = oldfree 3444 r = a0 3445 ok areg(a0,\freed&anyareg) %if rset # ref 3446 restore(freed) 3447 free = free&(\(a0b<<(r-a0))) 3448 c_reg_content(r) = p+ad 3449 m = r+(dispmode-a0); v = 0; !0(A?) 3450 ->setmode 3451 3452 funcall: 3453 commandeer(c_free) 3454 call 3455 r = typecell(dx_type)_reg&15+d0 3456 c_reg_ccx = pp %and c_reg_ccy = 0 %if dx_flags&okflag # 0 3457 endloadr: 3458 free = oldfree 3459 %if rset # ref %then ok reg(r) 3460 restore(freed) 3461 ->endload 3462 3463 rcall: 3464 flush %if pendcond # 0 3465 update sp 3466 !<= np0 %and dict(x)_act = concat %cycle 3468 dp_x = dict(x)_x; !first of pair 3469 call; free = c_free 3470 x = dict(x)_y; dp_x = x 3471 %repeat 3472 !<= 0 %and dict(curlab+1)_val >= 0 3477 %return 3478 3479 !!!!!!!!!!!!!!!!!!!!!!!!! Operators !!!!!!!!!!!!!!!!!!!!!!!!!!! 3480 3481 %routine EVALXY 3482 rset = rset&(\bregb) 3483 commandeer(d0b+d1b) 3484 %if 999 > weight(x) < weight(y) %start 3485 eval(y,d1b); eval(x,d0b) 3486 %else 3487 eval(x,d0b); eval(y,d1b) 3488 %finish 3489 %end 3490 3491 %routine STACKOP(%integer s) 3492 stsiz = s 3493 sp = c_sp 3494 eval(x,tostack); free = free!a0b 3495 eval(y,a0b+asad) 3496 plant(move,a7,a1); !dest (stack) 3497 structcall(act,s) 3498 forget(a0); forget(a1); forget(a0+2) 3499 %end 3500 3501 !< {prel,BASENAME,INDEX} 3504 dx == dict(x) 3505 m = imod(size(dx_type)) 3506 sx = 0; sy = 999999 3507 -> index1 3508 3509 !< endloadr 3517 3518 ![Note that all literal subtraction comes through as ADD] 3519 do(add): 3520 %if control&overbit # 0 %start 3521 -> dataload %if rset&(\anyareg) = 0 3522 rset = rset&(\anyareg) 3523 %finish 3524 -> dataload %if rset&(\bregb) = 0 3525 rset = rset&(\bregb) 3526 %if y < 0 %start 3527 %if y >= litquick %start; !(ADDQ,SUBQ) 3528 y = y-1 %and act = sub %if y&1 # 0; !'negate' if 'negative' 3529 eval(x,rset&free) 3530 ->fin1 3531 %finish 3532 %if y = -(128<<1) %start; !+128 3533 act = sub; y = y+1; !- -128 (MOVEQ) 3534 -> op2 3535 %finish 3536 %finish 3537 -> op1 3538 do(eor): 3539 -> dataload %if rset&(\bregb) = 0 3540 rset = rset&(\bregb) 3541 do(or): 3542 do(and): 3543 -> dataload %if rset&(\anyareg) = 0 3544 rset = rset&(\anyareg) 3545 op1: 3546 wx = weight(x) 3547 %if wx <= 1 %and y <= 0 %and y >= litmite %and rset&(\anyareg) # 0 %start 3548 rset = rset&(\anyareg) 3549 i = x; x = y; y = i 3550 %finish %else %if 999 > wx < weight(y) %start 3551 i = x; x = y; y = i 3552 %finish 3553 -> op2 3554 do(sub): 3555 %if control&overbit # 0 %start 3556 -> dataload %if rset&(\anyareg) = 0 3557 rset = rset&(\anyareg) 3558 %finish 3559 rset = rset&(\bregb) 3560 op2: 3561 eval(x,rset&free) 3562 op3: 3563 oldfree = free 3564 %if y <= 0 %and y >= litmite %and free&(anydreg!bregb) # 0 %start 3565 eval(y,anydreg!bregb); !bring Y to reg 3566 %finish %else %if act = eor %and y > 0 %start 3567 eval(y,anydreg) 3568 %finish %else %if act > sub %start 3569 %if x = breg %and y > 0 %start 3570 sy = tsize(y) 3571 %if sy = 1 %or (sy = 2 %and act = and) %start 3572 eval(y,val&(\anyareg)+sy< d7 3574 %finish %else eval(y,val&(\anyareg)) 3575 %finish %else eval(y,val&(\anyareg)) 3576 %else 3577 eval(y,val) 3578 %finish 3579 free = oldfree 3580 fin1: 3581 plant(act,y,x) 3582 -> fin3 %if act > sub 3583 fin2: 3584 plant(trapv,0,0) %if control&overbit # 0 3585 fin3: 3586 pp = x; c_reg_content(x) = p 3587 %if act <= opmax %then c_reg_ccx = p %and c_reg_ccy = 0 %c C %else forget cc 3589 %return 3590 3591 do(muls): do(mulu): 3592 -> dataload %if rset&(\(anyareg!bregb)) = 0 3593 rset = rset&(\(anyareg!bregb)) 3594 eval(x,rset&free) 3595 oldfree = free 3596 eval(y,anydreg) %if y > 0; ![could do better for short] 3597 free = oldfree 3598 plant(act,y,x) 3599 -> fin2 3600 3601 do(lsl): do(lsr): 3602 -> dataload %if rset&(\(anyareg!bregb)) = 0 3603 rset = rset&(\(anyareg!bregb)) 3604 eval(x,rset&free) 3605 %if y < 0 %and y >= litquick %start 3606 act = act!!(lsl!!lsr) %and y = y-1 %if y&1 # 0; !negate if neg 3607 %else 3608 oldfree = free; eval(y,anydreg); free = oldfree 3609 %finish 3610 ->fin1 3611 do(neg): 3612 %if y # 0 %start 3613 r = y; y = x; x = r 3614 act = sub 3615 -> do(sub) 3616 %finish 3617 do(not): 3618 -> dataload %if rset&(\(anyareg!bregb)) = 0 3619 rset = rset&(\(anyareg!bregb)) 3620 eval(x,rset&free) 3621 plant(act,0,x) 3622 -> fin3 3623 do(iabs): 3624 -> dataload %if rset&(\(anyareg!bregb)) = 0 3625 rset = rset&(\(anyareg!bregb)) 3626 x = y 3627 eval(x,rset&free) 3628 plant(move,x,x) %if c_reg_ccx # y %or c_reg_ccy # 0 3629 plantlit2(bge,0,2) 3630 plant(neg,0,x) 3631 ->fin2 3632 do(fabs): 3633 -> dataload %if rset&(\(anyareg!bregb)) = 0 3634 rset = rset&(\(anyareg!bregb)) 3635 x = y 3636 eval(x,rset&free) 3637 plantlit(and,16_7FFFFFFF,x) 3638 ->fin3 3639 3640 %routine DO SHIFT 3641 %integer i; 3642 i=0 3643 i = i+1 %and j = j>>1 %until j&1 # 0 3644 %if i = 1 %then plant(add,x,x) %else %start 3645 i = litref(i) 3646 %if i < litquick %start 3647 oldfree = free; eval(i,anydreg); free = oldfree 3648 %finish 3649 plant(asl,i,x) 3650 %finish 3651 %end 3652 3653 do(imul): 3654 -> dataload %if rset&(\(anyareg!bregb)) = 0 3655 rset = rset&(\(anyareg!bregb)) 3656 !Test for power of 2 or pair of powers of 2 3657 %if y < 0 %start 3658 j = litval(y) 3659 i = j&(j-1) 3660 %if i = 0 %or i&(i-1) = 0 %start 3661 eval(x,rset&free) 3662 do shift %if j&1 = 0 3663 %if j # 1 %start 3664 plant(move,x,prea7) 3665 do shift 3666 plant(add,posta7,x) 3667 %finish 3668 ->fin2 3669 %finish 3670 %finish 3671 do(fsub): do(fdiv): 3672 do(ipow): do(fpow): 3673 do(fadd): do(fmul): 3674 evalxy 3675 srcall(act) 3676 plant(trapv,0,0) %if act = imul %and control&overbit # 0 3677 forget(d1); r = d0 3678 forget cc 3679 -> endloadr 3680 3681 do(idiv): do(drem): 3682 %if control&halfbit # 0 %start 3683 act = divs %if act = idiv 3684 do(divs): do(divu): 3685 -> dataload %if rset&(\(anyareg!bregb)) = 0 3686 rset = rset&(\(anyareg!bregb)) 3687 eval(x,rset&free) 3688 oldfree = free 3689 eval(y,anydreg) 3690 free = oldfree 3691 %if act = drem %then plant(divs,y,x) %and plant(swap,0,x) %c C %else plant(act,y,x) 3693 plant(extl,0,x) 3694 -> fin3 3695 %finish 3696 evalxy 3697 srcall(idiv) 3698 putexp(act!!(idiv!!drem),xx,yy,inttype) 3699 %if act = idiv %start 3700 c_reg_content(d1) = item; r = d0 3701 %else 3702 c_reg_content(d0) = item; r = d1 3703 %finish 3704 forget cc 3705 ->endloadr 3706 3707 do(float): 3708 do(fneg): 3709 commandeer(d0b) 3710 eval(x,d0b) 3711 srcall(act) 3712 forget cc 3713 r = d0 3714 ->endloadr 3715 3716 do(concat): !not special case 3717 ![they have to be free] commandeer(d0b+bregb+a0b+a1b+a2b) 3718 fault(plexerr) %if free&(a0b+a1b+a2b+d0b+bregb) # a0b+a1b+a2b+d0b+bregb 3719 stackop(-256) 3720 endconc: 3721 %if rset&tostack = 0 %start 3722 %if c_sp # sp %start 3723 addimm(sp-c_sp,a7); c_sp = sp 3724 %finish 3725 %finish %else rset = a0b 3726 r = a0 3727 ->endloadr 3728 3729 !!!!!!!!!!!!!!!!!!!!! Conditions !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 3730 3731 %routine CONDSWOP 3732 !Swop condition operands, adjusting operator accordingly 3733 %integer temp 3734 temp = x; x = y; y = temp 3735 temp = xx; xx = yy; yy = temp 3736 temp = sx; sx = sy; sy = temp 3737 temp = wx; wx = wy; wy = temp 3738 case = case!!3 %if case&8 # 0; !no change for '=','#' 3739 %end 3740 3741 %routine UNSIGNED 3742 %if case&8 # 0 %start; !no change for '=','#' 3743 case = case!!8 3744 case = case!!4 %if case&2 # 0 3745 %finish 3746 %end 3747 3748 ![Some confusion here of which operand (weightier) to evaluate first 3749 ![ and which to bring to register 3750 ![EVAL improvements make possible greater finesse: 3751 ![ 1. Decide which to evaluate first (weightier) 3752 ![ 2. EVAL both 'val' 3753 ![ 3. If either in register, OK 3754 ![ 4. Load one 3755 ![*for IMP, conditions cannot be embedded in other expressions; 3756 ![*for Pascal, they can. This needs improvement to cover that. 3757 do(compare): 3758 flush %if pendcond # 0 3759 update sp 3760 sp = c_sp 3761 pp = pp+1; dp == dp[1] * Failed to analyse line 3761 DP==DP[1] ! * Failed to analyse line 3761 DP==DP[1] ! 3762 case = dp_act 3763 %if x <= 0 %start; ![1st literal: only for true,false] 3764 case = case!!1 %if x = 0; !invert for false 3765 pendcond = case&1+bra 3766 -> endcomp 3767 %finish 3768 %if x >= explim %start; !address 3769 dx == dict(x-ad); sx = 4 3770 %else 3771 dx == dict(x) 3772 tx == dict(dx_type); sx = size(dx_type) 3773 %finish 3774 dx_flags = dx_flags!rflag 3775 %if y >= explim %or y <= 0 %then sy = 4 %else sy = tsize(y) 3776 wx = 0 %and wy = 0 %and condswop %if c_reg_ccx = y %and c_reg_ccy = x 3777 %if c_reg_ccx # x %or c_reg_ccy # y %start; ![???unsigned???] 3778 %if y # 0 %start; !not comparison with zero 3779 wx = weight(x); wy = weight(y) 3780 condswop %if wx < 999 %and wy > wx+1 3781 %if x >= explim %or y >= explim %start; !one or other is address 3782 !swop if Y is not name (to use LEA) 3783 condswop %if 0 <= y-ad < dictlim %and dict(y-ad)_flags >= 0 3784 eval(x,anyareg) 3785 eval(y,sign+anyareg) 3786 plant(cmp,y,x) 3787 c_reg_ccx = xx; c_reg_ccy = yy 3788 %finish %else %if sx > 0 %start; !simple operand 3789 %if tx_flags&cat = realy %start 3790 eval(x,d0b); eval(y,d1b) 3791 srcall(fsub) 3792 forget(x) 3793 c_reg_ccx = xx; c_reg_ccy = yy 3794 %finish %else %if y < 0 %start; !comparison with literal 3795 %if y >= litmite %start 3796 eval(x,val+sx< a7 %and dict(x)_mode&63 = pcmode) %start 3799 eval(y,anydreg) 3800 condswop %and sx = sy %unless x <= d7 3801 %finish 3802 %else 3803 sx = 0 %if sx = 1; ![to ensure comparison fails?] 3804 eval(x,val+sx<= 999 %start; !both complex 3831 eval(x,tostack); free = free!a0b 3832 eval(y,anyareg&free+asad) 3833 x = freeareg(undef) 3834 plant(move,a7,x) 3835 %else 3836 eval(x,anyareg&free+asad) 3837 forget(x) 3838 eval(y,anyareg&free+asad) 3839 %finish 3840 i = free dreg 3841 %if tx_flags&cat = stringy %start; !string comparison 3842 plant(clr,0,i) 3843 plant(moveb,x+indir,i) 3844 %else 3845 plantlit(move,-sx-1,i) 3846 %finish 3847 plant(cmpmb,x+post,y+post) 3848 plantlit2(dbne,i,-4) 3849 forget(i); forget(y) 3850 %else 3851 ! [Routine call required: must bring complex to stack] 3852 %if wx >= 999 %start 3853 eval(x,tostack); free = free!a0b 3854 %if wy >= 999 %start 3855 stsiz = sy; stsiz = -stsiz %if tx_flags&cat # stringy 3856 eval(y,tostack) 3857 y = a1; plant(move,a7,y) 3858 sy = (imod(sy)+1)&(\1); sy = 256 %if sy = 0 3859 x = a0; plant(lea,tempd(a7,sy),x) 3860 %else 3861 eval(y,a1b+asad) 3862 x = a0; plant(move,a7,x) 3863 %finish 3864 %else 3865 eval(x,a0b+asad); eval(y,a1b+asad) 3866 %finish 3867 !<= dispmode) %start 3876 %if tx_flags&cat = stringy %or sx = 1 %start 3877 eval(x,ref) 3878 plant(tst+1<<8,0,x) 3879 forget cc; !*for now* 3880 unsigned 3881 %else 3882 eval(x,anyareg&free+asad) 3883 i = free dreg 3884 plantlit(move,-sx-1,i) 3885 plant(tst+1<<8,0,x+post) 3886 plantlit2(dbne,i,-4) 3887 forget(i); forget(x) 3888 %finish 3889 %else 3890 eval(x,anydreg) 3891 %if c_reg_ccx # xx %or c_reg_ccy # 0 %start 3892 plant(move,x,x); c_reg_ccx = xx; c_reg_ccy = 0 3893 %finish 3894 %finish 3895 %finish 3896 %finish 3897 pendcond = case 3898 endcomp: 3899 pendin = dp_x; pendout = dp_y 3900 checksp: 3901 %if c_sp # sp %start 3902 addimm(sp-c_sp,a7); c_sp = sp 3903 %finish 3904 !< endcomp 3923 3924 !< concat %or dy_act = prel 3936 f = free 3937 %if dy_x = x %start; !recursion ends, successfully 3938 s = tsize(x); s = -s %if dy_act # concat; !+ve unless string 3939 eval(x,a1b+asad) 3940 %else 3941 %result = FALSE %if dy_y >= np0 %or dy_y = x %c C %or %not easy(dy_x) * Failed to analyse line 3942 %RESULT =FALSE %IF DY_Y>=NP0 %OR DY_Y=X %ORNOT EASY(DY_X) ! * Failed to analyse line 3942 %RESULT =FALSE %IF DY_Y>=NP0 %OR DY_Y=X %ORNOT EASY(DY_X) ! 3943 %finish 3944 y = dy_y 3945 %if y >= np0 %and dict(y)_act = dtostring %start 3946 y = dict(y)_x; eval(y,tobyte+val); !character value 3947 r1 = clean reg 3948 plant(addb,one,x+indir); !inc length(dest) 3949 plant(moveb,x+indir,r1) 3950 plant(moveb,y,tempx(x,r1)); !append char 3951 forget(r1) 3952 %else 3953 eval(y,a0b+asad) 3954 structcall(dy_act,s) 3955 forget(a0); forget(a1) 3956 forget(d1); forget(d2) 3957 %finish 3958 free = f&(\a1b) 3959 %result = TRUE 3960 %end 3961 3962 %routine BEWARE(%integer dest) 3963 ![not foolproof: ?too expensive to do properly 3964 ! too inefficient to fail safe] 3965 %integer r,d 3966 %integerfn UNSAFE(%integer p) 3967 ![a bit cavalier] 3968 %cycle 3969 %result = FALSE %if p <= undef; !literal, basereg or undef 3970 %result = TRUE %if p = dest %or p = d {%or d >= np0 3971 p = p-ad %if p >= explim 3972 %result = FALSE %if p < np0 3973 %result = TRUE %if dict(p)_act > opmax; !funcall,mapcall 3974 %result = TRUE %unless dest # dict(p)_y < np0 3975 p = dict(p)_x 3976 %repeat 3977 %end 3978 forget(dest) %and %return %if dest <= a7 3979 d = dest; d = d-ad %if d >= explim 3980 %for r = d0,1,maxareg %cycle 3981 forget(r) %if unsafe(c_reg_content(r)) * Failed to analyse line 3981 FORGET(R) %IF UNSAFE(C_REG_CONTENT(R)) ! * Failed to analyse line 3981 FORGET(R) %IF UNSAFE(C_REG_CONTENT(R)) ! 3982 %repeat 3983 forget cc %if unsafe(c_reg_ccx) %or unsafe(c_reg_ccy) * Failed to analyse line 3983 FORGETCC %IF UNSAFE(C_REG_CCX) %OR UNSAFE(C_REG_CCY) ! * Failed to analyse line 3983 FORGETCC %IF UNSAFE(C_REG_CCX) %OR UNSAFE(C_REG_CCY) ! 3984 %end 3985 3986 %integerfn XFREE(%integer v,strong) 3987 %record(identinfo)%name dp 3988 %cycle 3989 v = v-ad %if v >= explim 3990 %exit %if v < dictlim 3991 dp == dict(v) 3992 %result = FALSE %unless xfree(dp_y,1) * Failed to analyse line 3992 %RESULT =FALSE %UNLESS XFREE(DP_Y,1) ! * Failed to analyse line 3992 %RESULT =FALSE %UNLESS XFREE(DP_Y,1) ! 3993 strong = 1 %if dp_y >= dictlim 3994 v = dp_x 3995 %repeat 3996 %result = TRUE %if v # x %or strong = 0 3997 %result = FALSE 3998 %end 3999 4000 !<= explim %start; !ad of ... 4013 wx = weight(xx-ad) 4014 dx == dict(xx-ad) 4015 sx = 4 4016 %else 4017 wx = weight(xx) 4018 dx == dict(xx) 4019 sx = size(dx_type) 4020 %finish 4021 tx == dict(dx_type) 4022 sp = c_sp-c_val 4023 %if sx <= 0 %start; !structure assignment 4024 !Structure 4025 ![for rec/string assignment beware corruption of stacked 4026 ! structure in computing DEST] 4027 update sp 4028 %if tx_flags&cat = stringy %start 4029 sx = -256 %if sx = 0; !string(*) 4030 op = -1; op = dict(y)_act %if y >= np0 4031 %if y = 0 %start; !"" 4032 eval(x,ref) 4033 plant(clr+1<<8,0,x) 4034 %finish %else %if op = dtostring %start 4035 y = dict(y)_x 4036 eval(y,tobyte+val); !character value 4037 eval(x,anyareg&free+asad) 4038 plant(moveb,one,x+post) 4039 plant(moveb,y,x+indir) 4040 forget(x) 4041 forget cc 4042 %finish %else %if act = jamass %or %not easy(y) %start * Failed to analyse line 4042 %FINISHELSEIF ACT=JAMASS %ORNOT EASY(Y) %START ! * Failed to analyse line 4042 %FINISHELSEIF ACT=JAMASS %ORNOT EASY(Y) %START ! 4043 %if op >= concat %and wx > 1 %start 4044 ! Danger of corruption of RHS 4045 stsiz = sx 4046 eval(y,tostack); free = free!a0b 4047 eval(x,a1b+asad) 4048 plant(move,a7,a0); y = a0 4049 structcall(strcopy,sx) 4050 %finish %else %if act # assign %or sx = -256 %or control&capbit = 0 %start 4051 ! No check needed 4052 %if wx > 1 %then eval(x,anyareg&free+asad) %and eval(y,anyareg&free+asad) %c C %else eval(y,anyareg&free+asad) %and eval(x,anyareg&free+asad) 4054 !not worth %if act # jamass %and sx >= -4 %start 4055 ! %cycle 4056 ! plant(moveb,y+post,x+post) 4057 ! sx = sx+1 4058 ! %repeat %until sx >= 0 4059 ! %else 4060 i = free reg(anydreg!bregb) 4061 %if act = jamass %start 4062 plantlit(move,mite(-sx-1),i) 4063 plant(moveb,i,x+post) 4064 plant(cmpb,y+post,i) 4065 plantlit2(bcs,0,6); ! 3 2-byte instructions ** 4066 plant(sub,one,x) 4067 plant(moveb,y+pre,i) 4068 %else 4069 plant(moveb,y+indir,i); !length (dirty OK) 4070 %finish 4071 plant(moveb,y+post,x+post) 4072 plant(subb,one,i) 4073 plantlit2(bcc,0,-6) 4074 forget(i) 4075 ! %finish 4076 %else 4077 %if wx > 1 %then eval(x,a1b+asad) %and eval(y,a0b+asad) %c C %else eval(y,a0b+asad) %and eval(x,a1b+asad) 4079 structcall(strcopy,sx) 4080 %finish 4081 forget(x); forget(y) 4082 forget cc 4083 %finish 4084 %finish %else %unless easy(y) %start * Failed to analyse line 4084 %FINISHELSEUNLESS EASY(Y) %START ! * Failed to analyse line 4084 %FINISHELSEUNLESS EASY(Y) %START ! 4085 eval(x,anyareg&free+asad) %if y = 0 %or wx > 1 4086 %if y # 0 %start 4087 sx = tsize(y) %if sx = 0 4088 eval(y,anyareg&free+asad) 4089 forget(y) 4090 y = y+post 4091 eval(x,anyareg&free+asad) %if wx <= 1 4092 %finish 4093 forget(x) 4094 %if sx = 0 %then fault(sizerr) %else move block(y,x+post,-sx) 4095 %finish * 4095 FAULT 51 %FINISH is not required * 4095 FAULT 51 %FINISH is not required 4096 beware(xx) 4097 -> checksp 4098 %finish * 4098 FAULT 51 %FINISH is not required * 4098 FAULT 51 %FINISH is not required 4099 !Simple operand 4100 %if c_val # 0 %start 4101 %if dx_val = sp %and dx_mode = c_mode %start 4102 %if sx = 4 %or x >= explim %then c_val = c_val-4 %c C %else c_val = c_val-2 4104 %finish 4105 update sp 4106 %finish 4107 op = move 4108 case = val; case = case+sx<= explim 4121 %if i >= np0 %start; !SOURCE complex 4122 %if dx_flags&okflag # 0 %or control&bassbit>>1<= explim %start 4125 %if dy_act = prel %and dy_x = x-ad %c C %and (dy_y < 0 %or dy_type = bytetype) %start 4127 y = dy_y 4128 y = litref(litval(y)*imod(size(dy_type))) %if dy_type # bytetype 4129 act = add 4130 -> tostore 4131 %finish 4132 %else 4133 %if dy_x = x %c C %and (dy_act < neg %or (dy_act = neg %and dy_y = 0)) %start 4135 act = dy_act; y = dy_y 4136 -> tostore 4137 %finish 4138 %finish 4139 %finish 4140 %if wx < 999 %then eval(y,case) %and eval(x,ref) %c C %else eval(x,ref) %and eval(y,case) 4142 %else 4143 eval(x,ref) 4144 %if y <= 0 %start 4145 %if y = 0 %and dx_flags&readable # 0 %then op = clr %c C %else %if y >= litmite %and sx = 4 %then eval(y,anydreg) 4147 %else 4148 eval(y,case) %unless y <= a7 4149 %finish 4150 %finish 4151 %if y # x %start 4152 %if 0 < y <= maxareg %and 0 < yy = c_reg_content(y) %start 4153 beware(xx) 4154 c_reg_content(y) = xx 4155 %finish %else beware(xx) 4156 plant(op+(sx&3)<<8,y,x) 4157 c_reg_ccx = xx; c_reg_ccy = 0 4158 %finish %else beware(xx) 4159 endass: 4160 dx_flags = dx_flags!okflag %if c_localdpos <= xx < dictlim %c C %and c_forward = 0 4162 %return 4163 4164 do(incass): !(for %for loop) 4165 flush %if pendcond # 0 4166 dx == dict(xx) 4167 sx = size(dx_type) 4168 wx = weight(x) 4169 act = add 4170 tostore: 4171 %if y = 0 %start; ![only for NOT,NEG] 4172 eval(x,ref) 4173 %finish %else %if y < 0 %start 4174 %if act = add %start; ![+- literal] 4175 %if y >= litquick %start; !-8:-1 or 1:8 4176 act = sub %and y = y-1 %if y&1 # 0; !negate if neg 4177 eval(x,ref) 4178 -> past 4179 %finish 4180 act = sub %and y = y+1 %if y = -(128<<1); !128=>-128 4181 %finish 4182 eval(x,ref) 4183 eval(y,anydreg) %if y >= litmite %and anydreg&free # 0 4184 %finish %else %if x <= a7 %start 4185 eval(y,val) 4186 %else 4187 %if 999 > wx < weight(y) %then eval(y,anydreg) %and eval(x,ref) %c C %else eval(x,ref) %and eval(y,anydreg) 4189 %finish 4190 past: 4191 plant(act+sx<<8,y,x) 4192 plant(trapv,0,0) %if control&overbit # 0 %and act <= sub 4193 beware(xx) 4194 c_reg_ccx = xx; c_reg_ccy = 0 4195 ->endass 4196 4197 4198 !!!!!!!!!!!!!!!!!!!!!! Returns and jumps !!!!!!!!!!!!!!!!!!!!!!!! 4199 ! 4200 do(return): !terminate procedure 4201 update sp 4202 %if c_type # 0 %start; !function,map 4203 r = typecell(c_dpid_type)_reg&15 4204 %if c_type > 0 %and size(c_type) > 0 %start; !simple fn 4205 flush %if pendcond # 0 %and pendin # 0 4206 i = y 4207 %if c_reg_content(r+d0) # y %start 4208 flush %if pendcond # 0 4209 eval(y,d0b< 0; !ie struct fn 4216 sp = c_sp 4217 eval(y,d0b< 0 %and pendin # 0 4235 save context(y) %if y # x; !exit not continue 4236 compile uncond branch(y) 4237 %return 4238 4239 do(repeat): 4240 update sp 4241 compile uncond branch(x) 4242 define label(x+1) %if dict(x+1)_val < 0 4243 %if y < 0 %start; !temp(s) declared 4244 c_val = y; c_temps = c_temps+y; !decrement temps 4245 update sp 4246 %finish 4247 %return 4248 4249 do(else): 4250 %if c_access # 0 %and c_access # -2 %start 4251 save context(y) 4252 compile uncond branch(y); !outward branch for %else 4253 %finish 4254 define label(x) %if x # 0 %and dict(x)_val < 0; !inward from false cond 4255 %return 4256 4257 do(goto): !user jump 4258 update sp 4259 c_forward = c_forward+1 %if dict(y)_val = 0 4260 addimm(c_temps,a7) %if c_temps # 0 4261 i = pendcond 4262 compile uncond branch(y) 4263 addimm(-c_temps,a7) %if i # 0 %and c_temps # 0 4264 %return 4265 4266 do(label): 4267 update sp 4268 define label(x) 4269 %return 4270 4271 do(stop): 4272 update sp 4273 flush %if pendcond # 0 4274 plant(clr,0,d0) 4275 srcall(signal) 4276 c_access = 0 4277 %return 4278 4279 do(signal): 4280 update sp 4281 flush %if pendcond # 0 4282 sp = c_sp 4283 pp = pp+1; dp == dp[1] * Failed to analyse line 4283 DP==DP[1] ! * Failed to analyse line 4283 DP==DP[1] ! 4284 xx = dp_x; yy = dp_y 4285 x = litval(x) 4286 %if yy # undef %start 4287 eval(yy,a0b+asad); x = x+64 4288 %finish 4289 %if xx # undef %start 4290 eval(xx,d2b); x = x+32 4291 %finish 4292 %if y # undef %start 4293 eval(y,d1b); x = x+16 4294 %finish 4295 x = litref(x) 4296 eval(x,d0b) 4297 %if control&sysbit # 0 %then plant(jmp,0,signal) %else plant(jsr,0,signal) 4298 %if c_sp # sp %start; ![earlier?] 4299 addimm(sp-c_sp,a7); c_sp = sp 4300 %finish 4301 c_access = 0 4302 %return 4303 4304 do(settrap): 4305 update sp 4306 push(d0+6); ![historical] 4307 push(mb) 4308 plant(pea,0,temp(pcmode,10)); !address of mask [2+2+2+4] 4309 c_sp = c_sp-4 4310 push(gb+indir); ![2 bytes] 4311 plant(move,a7,gb+indir); ![2 bytes] 4312 c_eventsp = c_sp 4313 c_forward = c_forward+1 4314 lreg(c_lab1-dictlim) = c_reg 4315 plant(bra,0,c_lab1); ![4 bytes] 4316 pflag(pc-1) = longjump; !**not to be shortened 4317 forget regs 4318 plant(dc,0,temp(absmode,litval(y))); !event mask 4319 ! store(litval(y),0); !event mask 4320 %return 4321 4322 do(swgoto): !switch jump 4323 flush %if pendcond # 0 4324 update sp 4325 dx == dict(x) 4326 dx_flags = dx_flags!rflag 4327 i = dx_val; !start of table 4328 dy == typecell(dx_type) 4329 get bounds(dy_xtype,sx,sy) 4330 %if y <= 0 %start; !literal subscript 4331 y = litval(y) 4332 i = i+y-sx 4333 addimm(c_temps,a7) %if c_temps # 0 4334 plant(bra,0,temp(labmode,prog(i))) 4335 prog(i) = dtemp_val; !updated by PCREL 4336 %else 4337 eval(y,d0b) 4338 %if i > pc %start; !first jump (I >= SWPC) 4339 c_forward = c_forward+(sy-sx+1) 4340 %if dx_flags&arrflag = 0 %start; !no check 4341 addimm(c_temps,a7) %if c_temps # 0 4342 plant(lea,temp(pcmode,10-sx-sx),a0); !LEA ?(PC),A0 4343 plant(add,d0,d0); !ADD D0,D0 4344 %else 4345 wx = 12 4346 %if c_temps # 0 %start 4347 wx = wx+2; wx = wx+2 %if c_temps > 8 4348 %finish 4349 plant(lea,temp(pcmode,wx),a0) 4350 srcall(index) 4351 addimm(c_temps,a7) %if c_temps # 0 4352 %finish 4353 plant(add+2<<8,tempx(a0,d0),a0); !ADD.W 0(A0,D0),A0 4354 plant(jmp,0,a0+indir); !JUMP (A0) 4355 %if dx_flags&arrflag # 0 %start 4356 store(sy>>16,0); store(sy,0) 4357 store(sx>>16,0); store(sx,0) 4358 store(0,0); store(2,0) 4359 %finish 4360 dx_val = pc 4361 %cycle 4362 store(prog(i),0) 4363 swpc = swpc+1 %if i = swpc; i = i+1 4364 sx = sx+1 4365 %repeat %until sx > sy 4366 %else; !just branch to earlier sequence 4367 ![gives wrong line number for error] 4368 ![wrong if temps] 4369 i = i-7 %if dx_flags&arrflag # 0 4370 plant(bra,0,temp(labmode,i-6)) 4371 %finish 4372 %finish 4373 c_access = 0 4374 %return 4375 4376 do(asize): 4377 %if y # 0 %start; !first: prime D0 4378 update sp 4379 eval(y,d0b); !basic itemsize 4380 %else 4381 srcall(asize) 4382 %finish 4383 pp = pp+1; dp == dp[1] * Failed to analyse line 4383 DP==DP[1] ! * Failed to analyse line 4383 DP==DP[1] ! 4384 xx = dp_x; yy = dp_y 4385 free = c_free-d0b; !not d0 4386 eval(xx,d1b); !lower 4387 eval(yy,d2b); !upper 4388 push(d0); !size 4389 push(d1); push(d2) 4390 forget regs 4391 free = free!(d1b+d2b) 4392 dict(x)_val = c_sp 4393 %return 4394 ! 4395 do(adok): ![spare code] 4396 !Push size of dynamic array (& 0-base value) for AGET 4397 update sp 4398 %if x # 0 %start 4399 %if x # d0 %then eval(x,d0b) %else srcall(asize) 4400 %finish 4401 push(y) %if y # 0 4402 push(d0) 4403 %return 4404 4405 do(aget): 4406 plant(move,x,d0) 4407 srcall(aget) 4408 plant(move,a7,x) 4409 %if y # 0 %start 4410 dx == dict(x) 4411 dx_val = dx_val+4 4412 plant(move,a7,d0) 4413 plant(add,d0,x) 4414 dx_val = dx_val-4 4415 %finish 4416 forget(d0); forget(a0) 4417 %return 4418 4419 %routine COMPILE ENTRY(%integer linked,arg) 4420 !Entry sequence generated at end 4421 %integer i,r,vsp,lastvsp,holdsp 4422 %record(identinfo)%name darg,tp 4423 holdsp = c_sp 4424 c_sp = 0; lastvsp = 0 4425 c_stack = c_stack-4 %if linked > 0; !allow for link 4426 %if linked = 0 %and c_status&onstack # 0 %start 4427 !justify addressing assumed for onstack parameters 4428 c_sp = 4; holdsp = holdsp-4; c_stack = c_stack-4 4429 %finish 4430 c_stack = c_stack-4; !and return address 4431 c_totstack = c_stack %if c_stack < c_totstack 4432 %if control&stackbit # 0 %c C %and (c_status&unknown # 0 %or c_totstack < -128) %start 4434 plantlit(move,c_stack,breg); !*ok - gets cleared* 4435 srcall(stackok) 4436 %finish 4437 %if level > outerlevel %and linked > 0 %start; !link required 4438 %if level > 1 %start 4439 plant(move,tempd(gb,level<<2),prea7); !MOVE ?(GB),-(SP) 4440 plant(move,a7,tempd(gb,level<<2)); !MOVE SP,?(GB) 4441 %else 4442 plant(link,0,f1); !LINK #0,Ax 4443 %finish 4444 %finish 4445 darg == dict(arg) 4446 %cycle 4447 arg = darg_link 4448 %exit %if arg = 0 4449 darg == dict(arg) 4450 %if darg_val <= 0 %start; !passed in reg, not on stack 4451 vsp = darg_val 4452 r = darg_reg&15+d0 4453 %if darg_flags&mflag # 0 %or linked > 0 %start 4454 addimm(lastvsp-c_sp,a7); c_sp = lastvsp 4455 i = nsize(darg) 4456 %if i > 0 %start 4457 ! name or simple operand by value 4458 !NB MOVE.B transfers to hi byte 4459 plant(move+i<<8,r,prea7) 4460 %finish %else %if darg_flags&proc # 0 %start; !proc as param 4461 plant(move,r,prea7) 4462 plantlit(movew,16_4EF9,prea7) 4463 %else; !structure by value 4464 tp == typecell(darg_type) 4465 %if tp_flags&cat = stringy %start 4466 %if control&capbit # 0 %and tp_size > -256 %start 4467 plantlit(cmp+1<<8,-tp_size,r+indir) 4468 plantlit2(bcs,0,4) 4469 srcall(check) 4470 %finish 4471 i = c_sp-vsp 4472 addimm(-i,a7); !SP = SP-bytes 4473 extend stack(i) 4474 !MOVE.B length,Dx 4475 plant(moveb,r+indir,breg) 4476 !MOVE.B 0(Ay,Dx),0(SP,Dx) 4477 plant(moveb,tempx(r,breg),tempx2(a7,breg)) 4478 plant(subb,one,breg) 4479 plantlit2(bcc,0,-10) 4480 %else; !fixed length structure 4481 free = bregb 4482 push block(r,c_sp-vsp) 4483 %finish 4484 %finish 4485 c_sp = vsp 4486 %finish 4487 lastvsp = vsp 4488 %finish 4489 %repeat 4490 %if c_sp # 0 %start; !there are accesses to params 4491 addimm(lastvsp-c_sp,a7) 4492 c_sp = holdsp 4493 %finish %else c_sp = holdsp-lastvsp; !reduce 4494 %end 4495 4496 do(end): 4497 compile entry(c_status&globbed,c_dpid_type) 4498 %return 4499 4500 do(*): intern(8) 4501 do(0): !null action 4502 %end; !eval 4503 4504 %routine COMPILE(%integer startp) 4505 %integer p 4506 {?} show exp(startp) %if control&explist # 0 %and control&list # 0 4507 np = np0 %and %return %if faultnum > 0 4508 pendcond = 0 4509 p = startp-1 4510 %cycle 4511 free = c_free 4512 p = p+1 4513 %if p >= np %start 4514 %if startp = np0 %start 4515 np = np0 4516 flush %if pendcond > 0 4517 %return 4518 %finish 4519 np = startp; startp = np0; p = startp 4520 %finish 4521 %if c_reg_line # line %and control&(tracebit!diagbit!linebit) # 0 %start 4522 flush %if pendcond > 0 4523 pendcond = -1 4524 %finish 4525 eval(p,inst) 4526 %repeat 4527 %end; !compile 4528 4529 %routine SET FIRST ENTRY 4530 %integer j,k,p 4531 %record(identinfo)%name dp 4532 firstpos = dictlim; firstentry = finalbound 4533 p = 0 4534 %cycle 4535 p = p+1 4536 %exit %if p >= dlim 4537 dp == dict(p) 4538 %continue %if dp_mode # procmode 4539 %continue %if dp_val >= firstentry 4540 j = dp_val 4541 %if j <= 0 %start 4542 %continue %if j = 0 4543 k = -j 4544 %cycle 4545 j = k<<1 4546 k = code word(j)&16_FFFF 4547 %repeat %until k = 0 4548 %continue %if j >= firstentry 4549 %finish 4550 firstentry = j; firstpos = p 4551 %repeat 4552 %end 4553 4554 %routine DEFINE ENTRY(%integer chain,entry,pid) 4555 %integer j 4556 %cycle 4557 chain = chain<<1 4558 report(reacherr,pid,0) %unless 0 = is short(entry-chain) 4559 j = code word(chain)&16_FFFF 4560 !$IF VAX 4561 { final(chain) <- (entry-chain)>>8; final(chain+1) <- entry-chain 4562 !$IF APM 4563 shortinteger(final0+chain) <- entry-chain 4564 !$FINISH 4565 chain = j 4566 %repeat %until chain = 0 4567 %end 4568 4569 %routine CHECK REACH(%integer blocksize) 4570 !Add stepping stones if necessary 4571 %integer i 4572 %cycle 4573 i = blocksize+cad 4574 croak("Program too big") %if i >= ownbase 4575 %return %if i-firstentry < 31000; !enough leeway 4576 %return %if blocksize >= 32000 %or cad-firstentry >= 32760; !hopeless 4577 %if dict(firstpos)_val < 0 %start 4578 define entry(-dict(firstpos)_val,cad,firstpos) 4579 set code word(16_6000); !BRA 4580 dict(firstpos)_val = -cad>>1 4581 set code word(0) 4582 %else 4583 dict(firstpos)_val = cad 4584 set code word(16_6000); !BRA 4585 set code word(firstentry-cad) 4586 %finish 4587 steps = steps+2 4588 set first entry 4589 %repeat 4590 %end 4591 4592 %routine PUT WORD(%integer v) 4593 printsymbol(v>>8&255); printsymbol(v&255) 4594 %end 4595 4596 %routine DO EXTERNALS(%integer chain,specs) 4597 %integer k,a,b 4598 %record(identinfo)%name dp,tp 4599 4600 byteinteger(charlim) = 0; ![see test for %alias] 4601 value = 2 4602 %cycle 4603 dp == dict(chain) 4604 a = dp_text+char0; b = byteinteger(a) 4605 %if byteinteger(a+b+1)&128 # 0 %start; !aliased 4606 a = a+b+1; b = byteinteger(a)-128 4607 %finish 4608 value = value+(b+14)&(\1) 4609 %if specs >= 0 %start; !for real 4610 put word(dp_flags&(ext+proc)!sign16) 4611 put word(dp_mode) 4612 k = 0 4613 %if dp_flags&proc # 0 %start 4614 !create type word 4615 tp == dict(dp_type) 4616 k = 4; k = 6 %if tp_type # 0; !100:R 11x:F,M 4617 %cycle 4618 k = k+1 %if tp_reg&8 # 0; !0:dreg, 1:areg 4619 %exit %if tp_link <= 0 4620 tp == dict(tp_link); k = k<<1 4621 %repeat 4622 !special code (11) for %routine ...(%string(255) parm) 4623 k = k+2 %if k = 9 %and tp_type = stringtype %and tp_flags >= 0 4624 %finish 4625 put word(k>>16); put word(k) 4626 put word(dp_val>>16); put word(dp_val) 4627 put word(b<<8+byteinteger(a+1)) 4628 %cycle 4629 a = a+2; b = b-2 4630 %exit %if b < 0 4631 k = byteinteger(a)<<8 4632 k = k+byteinteger(a+1) %if b > 0 4633 put word(k) 4634 %repeat 4635 %finish 4636 chain = dp_link 4637 %repeat %until chain = 0 4638 %if specs >= 0 %start 4639 put word(0) 4640 put word(0) %if value&3 # 0 4641 %finish 4642 value = (value+3)&(\3) 4643 %end 4644 ! 4645 %routine PUTACT(%integer act,x,y) 4646 dict(np)_act = act; dict(np)_x = x; dict(np)_y = y 4647 np = np+1 4648 %end 4649 4650 %routine COMPILE END 4651 %integer i,j,x,y,entry,lim 4652 %if c_reg_line # line %and control&(diagbit!linebit!tracebit) # 0 %c C %and level > outerlevel %and c_access # 0 %start 4654 pendcond = -1 4655 flush 4656 %finish 4657 !Pop event block 4658 %if c_eventsp # 0 %start 4659 plant(move,temp(c_mode,c_eventsp),gb+indir) 4660 forget cc 4661 %finish 4662 !Put pre-amble 4663 codeflag = '^'; x = pc; !preserve 4664 putact(end,0,0) 4665 compile(np0) 4666 fill code(1) %if cad&1 # 0 4667 check reach((pc-c_localpc)<<1) 4668 entry = cad 4669 y = x 4670 %while y < pc %cycle 4671 %if pflag(y) = indglobal %then set code word(dict(prog(y))_val-cad) %c C %else set code word(prog(y)) 4673 y = y+1 4674 %repeat 4675 codeflag = ' '; pc = x; !restore 4676 !Generate final sequence 4677 %if c_access # 0 %start 4678 %if level > outerlevel %and c_status&globbed # 0 %start 4679 %if level > 1 %start; !display in store 4680 plant(move,tempd(gb,level<<2),a7); !MOVE ?(GB),SP 4681 plant(move,posta7,tempd(gb,level<<2)); !MOVE (SP)+,?(GB) 4682 forget cc 4683 %else 4684 plant(unlk,0,f1) 4685 %finish 4686 %finish %else %if c_sp < 0 %start; !some stack extension 4687 addimm(-c_sp,a7) 4688 %finish 4689 %if level > outerlevel %start 4690 c_dpid_flags = c_dpid_flags!okflag %if c_type > 0 %c C %and c_status&wrongcc!c_reg_ccx!c_reg_ccy = 0 4692 plant(rts,0,0) 4693 %else 4694 plant(move,0,d0); srcall(signal); !%stop 4695 %finish 4696 %else; !no return from procedure 4697 c_dpid_flags = c_dpid_flags!noret 4698 %finish 4699 !Set start address 4700 x = c_dpid_val 4701 define entry(-x,entry,c_pid) %if x < 0; !forward refs in FINAL 4702 c_dpid_val = entry 4703 ! 4704 lim = cad+(pc-c_localpc-c_shorts+zeroshorts)<<1 4705 x = c_localpc; c_shorts = zeroshorts; !reset 4706 %while x < pc %cycle 4707 y = prog(x); j = pflag(x) 4708 %if j # 0 %start 4709 %if j < zeroshorts %start 4710 %if j <= longjump %start; !shortjump/jump/longjump 4711 jumps = jumps+1 4712 y = (y-pflag(y)-x+c_shorts)<<1 4713 %if j = shortjump %start 4714 cad = cad-2 4715 y = prog(x-1)+y&255 4716 c_shorts = c_shorts+1 4717 %finish 4718 %finish %else %if j = indglobal %start; !procedure 4719 i = dict(y)_val 4720 %if i <= 0 %start; !not yet encountered 4721 dict(y)_val = -(cad>>1); y = -i 4722 %else 4723 i = i-cad 4724 report(reacherr,y,0) %unless 0 = is short(i) 4725 y = i 4726 %finish 4727 %else {global,negglobal,bigglobal} 4728 %if j # global+1 %start 4729 y = y&16_FFFF 4730 y = y+65536 %if j # global; !bigglobal 4731 %finish 4732 y = y-cad 4733 %unless 0 = is short(y) %start 4734 %if prog(x-1)&16_F1FF # 16_41FA %start; !LEA (PC),Ax 4735 report(creacherr,0,cad) 4736 %else 4737 i = cad; cad = lim 4738 set code word(prog(x-1)!!(16_41FA!!16_207C)); !MOVEI #,Ax 4739 set code longword(y-2) 4740 set code word(prog(x-1)!!(16_41FA!!16_D1D7)); !ADD (SP),Ax 4741 set code word(16_4E75); !RTS 4742 lim = cad; cad = i-2 4743 set code word(16_6100); !BSR 4744 y = lim-10-cad 4745 steps = steps+5 4746 %finish 4747 %finish 4748 %finish 4749 %finish 4750 %finish 4751 !$IF VAX 4752 { final(cad) <- y>>8; final(cad+1) <- y 4753 !$IF APM 4754 shortinteger(final0+cad) <- y 4755 !$FINISH 4756 cad = cad+2 4757 x = x+1 4758 %repeat 4759 cad = lim 4760 forget all 4761 %end; !compile end 4762 4763 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 4764 !!!!!!!!!!!!!!! end of Code Generation !!!!!!!!!!!!!!!!!!!!!!! 4765 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 4766 ! 4767 !<= c_localdpos 4846 ! %repeat 4847 %if level > outerlevel %start 4848 charlim = c_localtext 4849 ranges = dict(ranges)_hlink %while ranges >= c_parlim 4850 c_dpid_type = crunched(c_dpid_type) 4851 level = level-1; c = hold(level) 4852 control = control&editbit ! c_oldcontrol&(\editbit) 4853 %finish 4854 dictshown = dlim %if dictshown > dlim 4855 starts = 0; cycles = 0 4856 %end 4857 4858 %routine FIXUP SWITCH VECTOR(%integer pos,%record(identinfo)%name dp) 4859 %integer x,y,j,default,temp,lo,hi 4860 %record(identinfo)%name tp==typecell(dp_type) * Failed to analyse line 4860 %RECORD (IDENTINFO) %NAME TP==TYPECELL(DP_TYPE) ! * Failed to analyse line 4860 %RECORD (IDENTINFO) %NAME TP==TYPECELL(DP_TYPE) ! 4861 x = dp_val 4862 default = dp_link; default = pc %if default = 0 4863 get bounds(tp_xtype,lo,hi) 4864 %if dp_flags&arrflag = 0 %then j = pflag(x-1)+lo %c C %else j = pflag(x-7); !allow for dope info 4866 j = x-j; !base position 4867 %while lo <= hi %cycle; !For each element 4868 y = prog(x) 4869 %if y <= 0 %start; !not set 4870 %if dp_link = 0 %start; !no default 4871 report(slabmissing+warn,pos,lo) 4872 c_access = 1 4873 %finish 4874 %if y < 0 %start; !explicit jump(s) to this one 4875 y = -y 4876 %cycle; !define jumps to default 4877 temp = y; y = prog(temp); prog(temp) = default 4878 %repeat %until y = 0 4879 %finish 4880 y = default 4881 %finish 4882 prog(x) = (y-pflag(y)-j)<<1 4883 x = x+1; lo = lo+1 4884 %repeat 4885 %end 4886 4887 %routine CLOSE BLOCK 4888 %integer miss,under,pos,base 4889 %record(identinfo)%name dp 4890 ! WRONGCC is clear if all %result statements leave correct CC 4891 %if c_type > 0 %and c_status&wrongcc = 0 %start 4892 ! set special values and see if they survive exit sequence 4893 c_reg_ccx = 0; c_reg_ccy = 0 4894 %finish 4895 %if c_return # 0 %start 4896 %if c_return = -(pc-1) %and c_access = 0 %start 4897 c_return = -prog(pc-1); pc = pc-2 4898 %finish 4899 define jumps(c_return); !must precede switch fixup 4900 c_access = -1 4901 %finish 4902 pflag(pc) = c_shorts; !in case of terminal switch labels 4903 %if c_status&hadswitch # 0 %start 4904 pos = c_localdpos 4905 %while pos < dlim %cycle 4906 dp == dict(pos) 4907 fixup switch vector(pos,dp) %if dp_mode = labmode %and dp_type # 0 4908 pos = pos+1 4909 %repeat 4910 %finish 4911 compile end 4912 c_totstack = c_totstack-c_extra 4913 c_totstack = -c_totstack %if c_status&unknown = 0; !positive if firm 4914 typecell(c_dpid_type)_val = c_totstack 4915 {?} %if control&maplist # 0 %start 4916 {?} put ident(c_pid,0) 4917 {?} mark at(20) 4918 {?} put string(" code:") 4919 {?} put num(cad-c_localad-accounted) 4920 {?} put string(" entry:") 4921 {?} put num(c_dpid_val-c_localad-accounted) 4922 {?} put string(" stack:"); put num(-c_stack) 4923 {?} putsym('/'); put num(imod(c_totstack)) 4924 {?} put sym('+') %if c_totstack < 0 4925 {?} accounted = cad-c_localad 4926 {?} print line 4927 {?} %finish 4928 !Check identifier usage 4929 miss = 0; under = 0 4930 base = c_localdpos; base = 0 %if level = outerlevel 4931 pos = dlim; dp == dict(pos) 4932 %while pos > base %cycle 4933 pos = pos-1; dp == dp[-1] * Failed to analyse line 4933 DP==DP[-1] ! * Failed to analyse line 4933 DP==DP[-1] ! 4934 %if dp_flags&ext = 0 %start 4935 !< 0 %start; !user id 4938 set hashhead(string(dp_text+char0)) 4939 %if head = pos %start; !still active 4940 head = dp_hlink; !remove from hash list 4941 check: %if dp_flags&spec # 0 %start 4942 dp_hlink = miss; miss = pos 4943 %finish %else %if ((dp_flags&(readable+rflag) = readable %and dp_mode # litmode) %c C %or (dp_flags&(writable+okflag+wflag+spec) = writable)) %c C %and pos >= c_localdpos %and dp_mode # 0 %and dp_flags&typeid = 0 %c C %and control&(list!maplist) # 0 %start 4947 dp_hlink = under; under = pos 4948 %finish 4949 %finish 4950 %finish 4951 %finish %else %if level = outerlevel %start; !external, external spec 4952 %if dp_flags&spec = 0 %start; !external object 4953 dp_link = externs; externs = pos 4954 %finish %else %if dp_flags&(rflag+wflag) # 0 %start 4955 !external spec (used) 4956 dp_link = extspecs; extspecs = pos 4957 %finish 4958 %finish 4959 %repeat 4960 report(idmissing,miss,0) %if miss # 0 4961 %if under # 0 %and c_faults = 0 %start 4962 put ident(under,1) 4963 put string(" underused") 4964 print line 4965 %finish 4966 pop context 4967 set first entry %if firstpos >= dlim 4968 %end; !CLOSE BLOCK 4969 4970 %routine ERROR(%integer case) 4971 faultp = atomp 4972 report(case,0,0) 4973 %signal fail 4974 %end 4975 4976 %constinteger DUD=63 4977 %routine SYNTAX ERROR 4978 %if atom = dud %then error(atomerr+point) %else error(formerr+point) 4979 %end 4980 4981 %routine EXPFAULT(%integer case) 4982 %if faultnum = 0 %or expp < faultp %start 4983 faultnum = case!point; faultp = expp 4984 %finish 4985 %end 4986 4987 %routine NONSTANDARD(%integer case) 4988 %integer b 4989 %owninteger hadit=0 4990 b = 1<= 0 %start; !first time 5003 fault(namerr+point+now) 5004 %if charmin-newlen-80 >= charlim %start 5005 dmin = dmin-1; dmin0 = dmin 5006 charmin = charmin-newlen-1 5007 string(charmin) = string(charlim) 5008 dict(dmin)_text = charmin-char0 5009 head == dict(head)_hlink %while head > 0; !find last link 5010 dict(dmin)_hlink = head; head = -dmin 5011 %finish 5012 %finish %else others = others+1 5013 %signal fail 5014 %end 5015 5016 %routine FIND OP(%integer mnemonic,%integername op,types) 5017 %integer i 5018 i = 0 5019 %cycle 5020 i = i+2 5021 error(namerr) %if i > defmax+defmax 5022 %repeat %until def(i) = mnemonic 5023 types = def(i-1); op = i>>1 5024 %end 5025 5026 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 5027 !!!!!!!!!!!!!!!!!!!! Source input !!!!!!!!!!!!!!!!!!!!!!!!!!!! 5028 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 5029 5030 %routine READ LINE(%integer flag) 5031 ! Read (or otherwise make available) the next source line 5032 ! Output any pending error report; *NB* 5033 ! Skip remnant of previous line if SYM # NL *NB* 5034 ! Set LINESTART to point to start of new line 5035 ! Print new line on list output stream if listing requested 5036 ! (Direct output routines CF diagnostics) 5037 report(faultnum,0,0) %if faultnum # 0 5038 %while sym > nl %cycle; !Skip remnant 5039 sym = byteintegeR(fp); fp = fp+1 5040 %repeat 5041 line = line+1 5042 %while fp = curlim %cycle 5043 %if curlim # cur_lim2 %start; !in part1 of file 5044 fp = cur_start2 5045 %finish %else %if curfile = main %start; !on main 5046 %signal done 5047 %else 5048 cur_flag = -1 5049 !! disconnect edfile(cur) 5050 curfile = curfile-1 5051 cur == file(curfile) 5052 fp = cur_fp; line = cur_line 5053 control = fcontrol(curfile) 5054 inclim = dlim %if level = outerlevel %and c_status < hadon 5055 %finish 5056 curstart = cur_start2; curlim = cur_lim2 5057 %if fp < curstart %or fp > curlim %start 5058 curstart = cur_start1; curlim = cur_lim1 5059 %finish 5060 %repeat 5061 linestart = fp 5062 %if flag = 0 %start 5063 flag = ' '; flag = '&' %if curfile # main 5064 %finish 5065 listflag = flag 5066 %if control&list # 0 %start 5067 time1 = time1-cputime 5068 print line %if rep # "" 5069 show dict(dictshown) %if control&dictlist # 0 5070 dictshown = dlim 5071 write(line,4); print symbol(listflag) 5072 print symbol(' ') 5073 %cycle 5074 sym = byteintegeR(fp); fp = fp+1 5075 print symbol(sym) 5076 %repeat %until sym <= nl 5077 fp = linestart 5078 time1 = time1+cputime 5079 %finish 5080 sym = 0 5081 %end; !READ LINE 5082 5083 !<= 10 %start 5259 i = sym!casebit-'a'; i = i+10 %if i >= 0 5260 %finish 5261 %end 5262 5263 matched = 0 5264 again: s(tab): 5265 read line(0) %if sym = nl 5266 again1: 5267 %cycle 5268 sym = byteintegeR(fp); fp = fp+1 5269 %repeat %until sym # ' ' 5270 atomp = fp; !(actually one after) 5271 atoms = atoms+1 5272 -> s(sym) 5273 linebreak: s(nl): 5274 %result = terminator %if atom # comma 5275 continuation: 5276 read line('+') 5277 -> again1 5278 5279 s('{'): 5280 comments = comments+1 5281 %cycle 5282 sym = byteintegeR(fp); fp = fp+1 5283 -> linebreak %if sym = nl 5284 %repeat %until sym = '}' 5285 -> again 5286 5287 s('+'): %result = plus 5288 s('-'): fp = fp+1 %and %result = arrow %if byteintegeR(fp) = '>' 5289 -> continuation %if byteintegeR(fp) = nl 5290 %result = minus 5291 s('*'): %result = star 5292 s('/'): fp = fp+1 %and %result = slash2 %if byteintegeR(fp) = '/' 5293 %result = slash 5294 s('\'): fp = fp+1 %and %result = backslash2 %if byteintegeR(fp) = '\' 5295 fp = fp+1 %and %result = noteq %if byteinteger(fp) = '=' 5296 %result = backslash 5297 s('^'): fp = fp+1 %and %result = uparrow2 %if byteintegeR(fp) = '^' 5298 %result = uparrow 5299 s('~'): %result = tilde 5300 s('!'): fp = fp+1 %and %result = exclam2 %if byteintegeR(fp) = '!' 5301 %result = exclam 5302 s('&'): %result = ampersand 5303 s('.'): rval = 0 %and -> fraction %if '0' <= byteinteger(fp) <= '9' 5304 %result = dot 5305 s('='): fp = fp+1 %and %result = eqeq %if byteintegeR(fp) = '=' 5306 %result = equals 5307 s('#'): fp = fp+1 %and %result = noteqeq %if byteintegeR(fp) = '#' 5308 %result = noteq 5309 s('<'): fp = fp+1 %and %result = lesseq %if byteintegeR(fp) = '=' 5310 fp = fp+1 %and %result = noteq %if byteintegeR(fp) = '>' 5311 fp = fp+1 %and %result = lshift %if byteintegeR(fp) = '<' 5312 %result = less 5313 s('>'): fp = fp+1 %and %result = greateq %if byteintegeR(fp) = '=' 5314 fp = fp+1 %and %result = rshift %if byteintegeR(fp) = '>' 5315 %result = greater 5316 s('_'): %result = underline 5317 s(':'): %result = colon 5318 s(','): %result = comma 5319 s(';'): %result = terminator 5320 s('('): %result = left 5321 s('['): %result = leftb 5322 s(')'): %result = right 5323 s(']'): %result = rightb 5324 s('|'): %result = modsign 5325 s('@'): %result = atsign 5326 5327 s('M'): s('m'): 5328 fp = fp+1 %and -> charconst %if byteintegeR(fp) = '''' 5329 s('A'):s('B'):s('C'):s('D'):s('E'):s('F'):s('G'):s('H'): 5330 s('I'):s('J'):s('K'):s('L'):s('N'):s('O'):s('P'): 5331 s('Q'):s('R'):s('S'):s('T'):s('U'):s('V'):s('W'):s('X'): 5332 s('Y'):s('Z'):s('a'):s('b'):s('c'):s('d'):s('e'):s('f'): 5333 s('g'):s('h'):s('i'):s('j'):s('k'):s('l'):s('n'): 5334 s('o'):s('p'):s('q'):s('r'):s('s'):s('t'):s('u'):s('v'): 5335 s('w'):s('x'):s('y'):s('z'): 5336 -> keyword %if percent # 0 5337 newlen = charlim+1; hash = sym!casebit; !lower-case (if letter) 5338 byteinteger(newlen) = hash 5339 %cycle 5340 sym = byteintegeR(fp); fp = fp+1 5341 %repeat %until sym # ' ' 5342 %if sym = '''' %start; !damned IBM-style literals 5343 radix = 16 %and ->ibm %if hash = 'x' 5344 radix = 8 %and ->ibm %if hash = 'k' 5345 radix = 2 %and ->ibm %if hash = 'b' 5346 %finish 5347 sym = map(sym) 5348 %if sym # 0 %start 5349 %cycle 5350 newlen = newlen+1; byteinteger(newlen) = sym 5351 hash = hash<<1!!sym 5352 %cycle 5353 sym = byteintegeR(fp); fp = fp+1 5354 %repeat %until sym # ' ' 5355 sym = map(sym) 5356 %repeat %until sym = 0 5357 %finish 5358 fp = fp-1 5359 newlen = newlen-charlim; byteinteger(charlim) = newlen 5360 %if subbed # 0 %then head == dformat_link %c C %else head == hashindex(hash&255) 5362 item = head 5363 %if item # 0 %start 5364 %cycle 5365 ditem == dict(imod(item)) 5366 %exit %if string(ditem_text+char0) = string(charlim) %c C %and (item > a7 %or item < 0 %or control&lowbit # 0) 5368 item = ditem_hlink 5369 %repeat %until item = 0 5370 %finish 5371 identatoms = identatoms+1 5372 %result = ident 5373 5374 s('%'): 5375 sym = byteintegeR(fp) 5376 -> again %unless 'a' <= sym!casebit <= 'z' 5377 fp = fp+1 5378 keyword: 5379 percent = 0 5380 p = syminit(sym!casebit) 5381 %cycle 5382 ! %cycle 5383 ! sym = byteintegeR(fp)!casebit 5384 ! %exit %if symbol(p) # sym 5385 %while symbol(p) = byteintegeR(fp)!casebit %cycle 5386 p = p+1; fp = fp+1 5387 %repeat 5388 %exit %if symbol(p) > 127 5389 atom = altdisp(p) 5390 %if atom = 0 %start 5391 %result = dud %unless sym!casebit = 'c' %and byteintegeR(fp) = nl 5392 ->continuation 5393 %finish 5394 p = p+atom 5395 %repeat 5396 percent = 1 %if 'a' <= byteintegeR(fp)!casebit <= 'z' 5397 subatom = altdisp(p) 5398 atom = symbol(p)-128 5399 %result = dud %if atom = 0 5400 %result = atom 5401 5402 ibm: 5403 nonstandard(20) 5404 item = -1; value = 0 5405 -> ibm1 5406 s('0'):s('1'):s('2'):s('3'):s('4'):s('5'):s('6'):s('7'):s('8'):s('9'): 5407 item = 0; type = inttype 5408 radix = 10; value = sym-'0' 5409 ibm1: 5410 %cycle 5411 %cycle 5412 %cycle 5413 sym = byteintegeR(fp); fp = fp+1 5414 %repeat %until sym # ' ' 5415 i = sym-'0' 5416 %if radix = 10 %start 5417 %exit %if i < 0 %or i >= 10 5418 fault(rangerr+point+warn) %if value > max10 %or (value=max10 %and i > maxdig) 5419 value = (value<<2+value)<<1+i 5420 %else 5421 i = sym!casebit-'a'+10 %if i >= 10 5422 %exit %if i < 0 %or i >= radix 5423 j = radix 5424 %cycle 5425 i = i+value %if j&1 # 0 5426 value = value<<1; j = j>>1 5427 %repeat %until j = 0 5428 value = i 5429 %finish 5430 %repeat 5431 %exit %unless sym = '_' 5432 radix = value 5433 %result = dud %if radix = 0 5434 value = 0 5435 %repeat 5436 %if item < 0 %start; !IBM-style 5437 %result = dud %if sym # '''' 5438 item = 0 5439 %else 5440 j = 0 5441 %if sym = '.' %start 5442 rval = value %if type = inttype 5443 fraction: 5444 j = 0 5445 type = realtype 5446 %cycle 5447 get sym 5448 %exit %unless 0 <= i < radix 5449 rval = rval*radix+i; j = j-1 5450 %repeat 5451 %result = dud %if j = 0 5452 %finish 5453 %if sym = '@' %start 5454 type = realtype %and rval = value %if type = inttype 5455 get sym 5456 value = 0 5457 %if sym = '+' %then get sym %c C %else %if sym = '-' %then value = 1 %and get sym 5459 %result = dud %unless 0 <= i < radix 5460 p = 0 5461 %cycle 5462 p = p*radix+i 5463 get sym 5464 %repeat %until %not 0 <= i < radix 5465 p = -p %if value # 0 5466 j = j+p 5467 %finish 5468 %if type = realtype %start 5469 rval = rval*radix^j %if j # 0 * Failed to analyse line 5469 RVAL=RVAL*RADIX^J %IF J#0 ! * Failed to analyse line 5469 RVAL=RVAL*RADIX^J %IF J#0 ! 5470 value = integer(addr(rval)) %if type = realtype 5471 %finish 5472 fp = fp-1; sym = 0 5473 %finish 5474 litatoms = litatoms+1 5475 %result = const 5476 5477 s(''''): 5478 charconst: 5479 item = 0; type = inttype 5480 value = 0 5481 %cycle 5482 sym = byteintegeR(fp); fp = fp+1 5483 %result = dud %if sym = nl; !?allow 5484 %if sym = '''' %start 5485 %exit %unless byteintegeR(fp) = '''' 5486 fp = fp+1 5487 %finish 5488 value = value<<8+sym 5489 %repeat 5490 %result = const %if value # 0 5491 %result = dud 5492 5493 s('"'): 5494 item = 0 5495 value = cad; type = stringtype 5496 i = line; j = linestart; p = 0 5497 %cycle 5498 sym = byteintegeR(fp); fp = fp+1 5499 %if sym = '"' %start 5500 %exit %if byteintegeR(fp) # '"' 5501 fp = fp+1 5502 %finish 5503 p = p+1 5504 %if p > 255 %start 5505 sym = 0 5506 fp = atomp; linestart = j 5507 %result = dud 5508 %finish 5509 final(value+p) = sym 5510 read line('"') %if sym = nl 5511 %repeat 5512 %if p # 0 %start; !not empty string 5513 final(value) = p 5514 cad = cad+(p+1) 5515 %finish %else value = 0 5516 litatoms = litatoms+1 5517 %result = const 5518 5519 s(*): 5520 %result = dud 5521 %end; !NEXT ATOM 5522 5523 !< 0 %and f&ext = 0; !already exists 5565 charlim = charlim+newlen+1 5566 croak("Identifier space exhausted") %if charlim+80 >= charmin 5567 k = charlim-newlen-1-char0 5568 %if f&ext # 0 %and a(keyalias) %start * Failed to analyse line 5568 %IF F&EXT#0 %AND A(KEYALIAS) %START ! * Failed to analyse line 5568 %IF F&EXT#0 %AND A(KEYALIAS) %START ! 5569 get LITSTRING 5570 string(charlim) = string(final0+value) 5571 byteinteger(charlim) = byteinteger(charlim)+128 5572 charlim = charlim+byteinteger(charlim)-127 5573 %finish * 5573 FAULT 51 %FINISH is not required * 5573 FAULT 51 %FINISH is not required 5574 %result = k 5575 %end 5576 5577 %record(objinfo)%map DETAILS(%integer f,t,m,v) 5578 %ownrecord(objinfo) D=0 5579 d_flags = f; d_type = t 5580 d_mode = m; d_val = v 5581 %result == d 5582 %end 5583 5584 %routine DECLARE(%record(objinfo)%name d) 5585 %integer i 5586 %record(identinfo)%name dp 5587 dp == dict(dlim) 5588 %if speccing = 0 %start; !not within spec params 5589 %if item >= c_localdpos %start; !there already 5590 %if d_flags&spec = 0 %and ditem_flags&spec # 0 %start 5591 !body after spec (proc,label,typeid) 5592 %if d_flags&(ext+proc+typeid) = ditem_flags&(ext+proc+typeid) %start 5593 i = item 5594 %if d_flags&ext # 0 %start 5595 ![can't allow %ext%spec, then use, then %ext object] 5596 ->ok %if ditem_flags&rflag # 0; ![so create new entry] 5597 ditem_mode = d_mode; ditem_val = d_val 5598 %if a(keyalias) %start * Failed to analyse line 5598 %IF A(KEYALIAS) %START ! * Failed to analyse line 5598 %IF A(KEYALIAS) %START ! 5599 get LITSTRING; !ignore [should be identical] 5600 item = i 5601 %finish 5602 %finish 5603 %if d_flags&proc = 0 %start 5604 ditem_flags = ditem_flags&(\(spec+indirect)) 5605 %finish 5606 %return 5607 %finish 5608 %if ditem_flags&(ext+proc) = proc1 %and d_flags&ext # 0 %c C %and d_flags&proc # 0 %start; !(internal) %spec then %ext 5610 ditem_flags = ditem_flags-proc1+(d_flags&(ext+proc)) 5611 ditem_text = idtext(ext); !in case alias 5612 %return 5613 %finish 5614 %finish 5615 !<= dmin %start 5627 {?} show dict(0) %if control&logbit # 0 5628 croak("Too many identifiers") 5629 %finish 5630 %end; !DECLARE 5631 5632 %routine DECLARE ANON(%record(objinfo)%name d) 5633 speccing = speccing+1 5634 item = 0 5635 declare(d) 5636 speccing = speccing-1 5637 %end 5638 ! 5639 %routine DECLARE TEMP(%integer t) 5640 c_val = c_val+4; c_temps = c_temps+4 5641 declare anon(details(okflag+writable+readable,t,c_mode,c_sp-c_val)) 5642 %end 5643 ! 5644 %routine DECLARE RANGE(%integer type,lower,upper) 5645 !Type ident just declared 5646 %integer s 5647 %integerfn OK(%integer l,u) 5648 %result = TRUE %if (l <= lower %and upper <= u) {signed} %c C %or (0 <= lower %and upper <= u-l) {unsigned} 5650 %result = FALSE 5651 %end 5652 s = 4 5653 %if ok(-32768,32767) %start * Failed to analyse line 5653 %IF OK(-32768,32767) %START ! * Failed to analyse line 5653 %IF OK(-32768,32767) %START ! 5654 s = 2; s = 1 %if ok(-128,127) * Failed to analyse line 5654 S=1 %IF OK(-128,127) ! * Failed to analyse line 5654 S=1 %IF OK(-128,127) ! 5655 %finish * 5655 FAULT 51 %FINISH is not required * 5655 FAULT 51 %FINISH is not required 5656 ditem_details = details(typeid,type,absmode,sign) 5657 ditem_size = s 5658 declare anon(details(okflag,type,litmode,lower)) 5659 declare anon(details(okflag,type,litmode,upper)) 5660 ditem_hlink = ranges; ranges = item 5661 item = item-2 5662 %end 5663 5664 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 5665 !!!!!!!!!!!!!!!!!!!! Expressions !!!!!!!!!!!!!!!!!!!!!!!!!!!!! 5666 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 5667 5668 %owninteger LITERAL=0, JAMMY=0 5669 5670 %routine%spec GET EXPRESSION(%integer rank,etype) 5671 ! 5672 %integerfn VALOK(%integer wanted,t) 5673 %integer lo,hi,l,h,wc,tc 5674 %record(identinfo)%name wp,tp 5675 %result = TRUE %if wanted = t # recstar 5676 wp == typecell(wanted); tp == typecell(t) 5677 wc = wp_flags&(packed+cat); tc = tp_flags&(packed+cat) 5678 %if wc = tc %start; !same class 5679 %if wc&nonord = 0 %start; !ordinal wanted 5680 %if wp_type = tp_type %start; !same base-type 5681 %result = TRUE %if wp_type = wanted; !base-type (rather than subrange) 5682 %if dict(wanted+1)_mode # litmode %then get bounds(dict(wanted+1)_type,lo,hi) %c C %else lo = dict(wanted+1)_val 5684 %if dict(wanted+2)_mode # litmode %then get bounds(dict(wanted+2)_type,hi,hi) %c C %else hi = dict(wanted+2)_val 5686 %if item = 0 %start; !literal 5687 %result = TRUE %if lo <= value <= hi 5688 jammy = jammy!!1 5689 %else 5690 jammy = jammy!!1 %and %result = TRUE %if tp_type = t 5691 %if dict(t+1)_mode # litmode %then get bounds(dict(t+1)_type,l,h) %c C %else l = dict(t+1)_val 5693 %if dict(t+2)_mode # litmode %then get bounds(dict(t+2)_type,h,h) %c C %else h = dict(t+2)_val 5695 %if l >= lo %start 5696 %result = TRUE %if h <= hi 5697 jammy = jammy!!1 5698 %result = TRUE %if l <= hi 5699 %else 5700 jammy = jammy!!1 5701 %result = TRUE %if h >= lo 5702 %finish 5703 %finish 5704 expfault(rangerr) %if jammy # 0 5705 %result = TRUE 5706 %finish 5707 %finish %else %if wc = realy %start 5708 %result = TRUE 5709 %finish %else %if wc = stringy %start; !string wanted 5710 %result = TRUE %if wanted = stringstar 5711 %if item = 0 %start 5712 %result = TRUE %if value = 0; !empty string 5713 l = final(value)+1 5714 %else 5715 l = imod(tp_size) 5716 l = 256 %if l = 0 5717 %finish 5718 %if l > imod(wp_size) # 0 %start 5719 jammy = jammy!!1 5720 expfault(rangerr) %if item = 0 %and jammy # 0 5721 %finish 5722 %result = TRUE 5723 !< item 5788 %repeat %until %not a(slash) * Failed to analyse line 5788 %REPEATUNTILNOT A(SLASH) ! * Failed to analyse line 5788 %REPEATUNTILNOT A(SLASH) ! 5789 item = 0; value = set 5790 %end 5791 5792 %routine get MCODE 5793 %integer op,x,y,types 5794 5795 %integer%fn OPSIZE(%integer okbyte) 5796 %result = 0 %unless a(dot) * Failed to analyse line 5796 %RESULT =0 %UNLESS A(DOT) ! * Failed to analyse line 5796 %RESULT =0 %UNLESS A(DOT) ! 5797 sym = byteinteger(fp)&(\casebit); fp = fp+1 5798 %result = 4 %if sym = 'L' 5799 %result = 2 %if sym = 'W' 5800 %result = 1 %if sym = okbyte 5801 syntax error 5802 %end 5803 5804 %routine get MOP(%integer t,dummy,%record(identinfo)%name dp) 5805 !Get Mcode operand 5806 %constinteger HASHSIGN=noteq 5807 %integer sign,hold,holdval,m 5808 %if a(hashsign) %start * Failed to analyse line 5808 %IF A(HASHSIGN) %START ! * Failed to analyse line 5808 %IF A(HASHSIGN) %START ! 5809 get LITERAL(inttype) 5810 %return 5811 %finish * 5811 FAULT 51 %FINISH is not required * 5811 FAULT 51 %FINISH is not required 5812 sign = 0; hold = -1; holdval = 0 5813 sign = 1 %if a(minus) * Failed to analyse line 5813 SIGN=1 %IF A(MINUS) ! * Failed to analyse line 5813 SIGN=1 %IF A(MINUS) ! 5814 %if a(ident) %start * Failed to analyse line 5814 %IF A(IDENT) %START ! * Failed to analyse line 5814 %IF A(IDENT) %START ! 5815 matched = 0 5816 get mident(0,dlim) 5817 hold = item 5818 %if hold # 0 %start 5819 syntax error %if sign # 0 5820 %if item > a7 %start 5821 dp_flags = ditem_flags 5822 dp_mode = ditem_mode; dp_val = ditem_val 5823 %while a(recsub) %cycle * Failed to analyse line 5823 %WHILE A(RECSUB) %CYCLE ! * Failed to analyse line 5823 %WHILE A(RECSUB) %CYCLE ! 5824 dformat == typecell(ditem_type) 5825 syntax error %unless dformat_flags&cat = recy %c C %and ditem_flags&(name+indirect) = 0 5827 subbed = 1; get(ident); subbed = 0 5828 error(namerr+point) %if item <= 0 5829 dp_flags = ditem_flags; dp_type = ditem_type 5830 dp_val = dp_val+ditem_val 5831 item = dummy; ditem == dp 5832 %repeat * 5832 FAULT 52 %REPEAT instead of %FINISH for %START at line 5820 * 5832 FAULT 52 %REPEAT instead of %FINISH for %START at line 5820 5833 %return 5834 %finish 5835 %if op&255 = movem %and item > 0 %start 5836 matched = 0 5837 get regset 5838 %finish 5839 %return 5840 %finish * 5840 FAULT 51 %FINISH is not required * 5840 FAULT 51 %FINISH is not required 5841 holdval = value 5842 %finish %else %if a(const) %start * 5842 FAULT 51 %FINISH is not required * 5842 FAULT 51 %FINISH is not required * Failed to analyse line 5842 %FINISHELSEIF A(CONST) %START ! * Failed to analyse line 5842 %FINISHELSEIF A(CONST) %START ! 5843 hold = 0; holdval = value 5844 %finish * 5844 FAULT 51 %FINISH is not required * 5844 FAULT 51 %FINISH is not required 5845 holdval = -holdval %if sign # 0 5846 %if a(left) %start * Failed to analyse line 5846 %IF A(LEFT) %START ! * Failed to analyse line 5846 %IF A(LEFT) %START ! 5847 get mident(a0,a7) 5848 %if hold < 0 %start 5849 get(right) 5850 %if sign # 0 %then item = item+pre %c C %else %unless a(plus) %then item = item+indir %c C %else item = item+post * Failed to analyse line 5852 %IF SIGN#0 %THEN ITEM=ITEM+PRE %ELSEUNLESS A(PLUS) %THEN ITEM=ITEM+INDIR %ELSE ITEM=ITEM+POST ! * Failed to analyse line 5852 %IF SIGN#0 %THEN ITEM=ITEM+PRE %ELSEUNLESS A(PLUS) %THEN ITEM=ITEM+INDIR %ELSE ITEM=ITEM+POST ! 5853 %return 5854 %finish 5855 m = item+(dispmode-a0) 5856 %if a(comma) %start * Failed to analyse line 5856 %IF A(COMMA) %START ! * Failed to analyse line 5856 %IF A(COMMA) %START ! 5857 get mident(d0,a7) 5858 fault(rangerr) %unless 0 = is mite(holdval) 5859 m = m+(indexmode-dispmode) 5860 holdval = (item-d0)<<12+holdval&255 5861 holdval = holdval+16_0800 %if opsize(0) # 2 5862 %finish * 5862 FAULT 51 %FINISH is not required * 5862 FAULT 51 %FINISH is not required 5863 get(right) 5864 %else * 5864 FAULT 51 %FINISH is not required * 5864 FAULT 51 %FINISH is not required 5865 syntax error %if hold < 0 5866 m = absmode 5867 %finish 5868 dp_mode = m; dp_val = holdval 5869 item = dummy 5870 %end 5871 5872 %constinteger temp=((('t'&31)<<5+('e'&31))<<5+('m'&31))<<5+('p'&31) 5873 update sp 5874 !Pack mnemonic 5875 atomp = fp+1 5876 x = 0 5877 %cycle 5878 sym = byteinteger(fp); fp = fp+1 5879 %exit %unless 'A' <= sym&(\casebit) <= 'Z' 5880 sym = sym&31 5881 x = x<<5+sym 5882 %repeat 5883 fp = fp-1; sym = 0 5884 syntax error %if x = 0 5885 %if x = temp %start; !*TEMP ... 5886 value = 0 5887 matched = 0 %and get regset %if a(ident) * Failed to analyse line 5887 MATCHED=0 %AND GETREGSET %IF A(IDENT) ! * Failed to analyse line 5887 MATCHED=0 %AND GETREGSET %IF A(IDENT) ! 5888 c_free = value 5889 %return 5890 %finish 5891 x = x<<5 %until x&(31<<25) # 0 5892 x = x!16_C0000000 5893 find op(x,op,types) 5894 op = op+opsize('B')<<8 %if types&(sized!asized) # 0 5895 x = 0; y = 0 5896 %if types>>6&63 # 0 %start 5897 get MOP(types>>6&63,lablim,dtemp) 5898 x = normitem 5899 get(comma) %if types&63 # 0 5900 %finish 5901 %if types&63 # 0 %start 5902 get MOP(types&63,lablim+1,dtemp2) 5903 y = normitem 5904 %finish 5905 plant(op,x,y) 5906 forget regs; c_access = -1 5907 %end; !get MCODE 5908 5909 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 5910 5911 %integerfn REFOK(%integer wanted,t) 5912 %record(identinfo)%name wp,tp 5913 %result = TRUE %if t = wanted %or wanted = 0 %or t = 0 %or item!value = 0 5914 wp == typecell(wanted); tp == typecell(t) 5915 %if (wp_flags!!tp_flags)&(name+packed+cat) = 0 %start 5916 %if wp_flags&cat = arry %start 5917 !**check index compatible 5918 %result = TRUE %if refok(wp_type,tp_type) * Failed to analyse line 5918 %RESULT =TRUE %IF REFOK(WP_TYPE,TP_TYPE) ! * Failed to analyse line 5918 %RESULT =TRUE %IF REFOK(WP_TYPE,TP_TYPE) ! 5919 %finish %else %if wp_flags&cat = stringy %start 5920 %result = TRUE %if tp_size = 0 %or wp_size = 0 5921 !<= dictlim %start 5933 ! %if ditem_act = prel %and (ditem_y < 0 %or ditem_type = bytetype) %start 5934 ! value = ditem_y 5935 ! value = litref(litval(value)*imod(size(ditem_type))) %if ditem_type # bytetype 5936 ! putexp(add,ditem_x+ad,value,ditem_type) 5937 ! %return 5938 ! %finish 5939 %else 5940 %if ditem_mode = absmode %and ditem_flags >= 0 %start 5941 item = 0; value = ditem_val 5942 %return 5943 %finish 5944 %finish 5945 item = item+ad 5946 %end 5947 ! 5948 %routine COPY DOWN(%integer np1) 5949 %while np > np1 %cycle 5950 np = np-1; explo = explo-1 5951 dict(explo) = dict(np) 5952 %repeat 5953 %end 5954 5955 %routine GET REFERENCE(%integer reftype) 5956 get EXPRESSION(simple,reftype!sign16) 5957 %end 5958 ! 5959 %routine GET PARLIST(%integer special) 5960 %integer procnp,pact,hold,count,headitem,arg,p,q,restype 5961 %record(identinfo)%name hp,tp 5962 %record(identinfo)%name darg 5963 5964 %routine PUT ACTUAL 5965 item = litref(value) %if item = 0 5966 %if count&1 = 0 %then hold = item %c C %else putact(pact,hold,item) %and pact = 0 5968 count = count+1 5969 %end 5970 5971 %integerfn NO ALT 5972 %if hp_flags&alt = 0 %start; !no alternative 5973 expfault(typerr) 5974 %result = TRUE 5975 %finish 5976 item = hp_hlink 5977 %cycle 5978 report(internerr,0,6) %and %signal fail %if item <= 0 5979 ditem == dict(item) 5980 %exit %if string(ditem_text+char0) = string(hp_text+char0) 5981 item = ditem_hlink 5982 %repeat 5983 headitem = item; pact = headitem; hp == ditem 5984 arg = hp_type; darg == dict(arg); restype = darg_type 5985 %result = FALSE 5986 %end 5987 5988 %routine PUT BOUNDS(%integer ft,at) 5989 ! FT is TYPE of formal, AT of actual array 5990 %integer maxarg=arg * Failed to analyse line 5990 %INTEGER MAXARG=ARG ! * Failed to analyse line 5990 %INTEGER MAXARG=ARG ! 5991 %record(identinfo)%name ftp,atp,fxp,axp 5992 %cycle 5993 ftp == typecell(ft); atp == typecell(at) 5994 ! %if ftp_flags&indirect # 0 %start; !complete dope vector 5995 ! ![now only for %string(*)%array%name] 5996 ! intern(11) %unless ftp_type = stringstar 5997 ! item = at 5998 ! put actual 5999 ! maxarg = ft %if ft > maxarg 6000 ! %exit 6001 ! %finish 6002 %if ftp_flags&cat = stringy %start 6003 %exit %if ftp_size # 0 6004 %if atp_size # 0 %then item = litref(imod(atp_size)) %C C %else item = at-1 6006 put actual 6007 maxarg = ft-1 %if ft-1 > maxarg 6008 %exit 6009 %finish 6010 %if ftp_xtype >= arg %start; !index type 6011 fxp == typecell(ftp_xtype); axp == typecell(atp_xtype) 6012 %if dict(ftp_xtype+1)_mode # litmode %start; !non-literal lower 6013 item = atp_xtype+1 6014 item = 0 %and value = dict(atp_xtype+1)_val %if dict(atp_xtype+1)_mode = litmode 6015 put actual 6016 maxarg = ftp_xtype+1 %if ftp_xtype >= maxarg 6017 %finish 6018 %if dict(ftp_xtype+2)_mode # litmode %start; !non-literal upper 6019 item = atp_xtype+2 6020 item = 0 %and value = dict(atp_xtype+2)_val %if dict(atp_xtype+2)_mode = litmode 6021 put actual 6022 maxarg = ftp_xtype+2 %if ftp_xtype+1 >= maxarg 6023 %finish 6024 %finish 6025 ft = ftp_type; at = atp_type; !element types 6026 %repeat %until ft <= arg 6027 arg = maxarg; darg == dict(arg) 6028 %end 6029 6030 count = 0; hold = 0 6031 procnp = np 6032 headitem = item; pact = headitem; hp == ditem 6033 arg = hp_type; darg == dict(arg); restype = darg_type 6034 %if a(left) %start * Failed to analyse line 6034 %IF A(LEFT) %START ! * Failed to analyse line 6034 %IF A(LEFT) %START ! 6035 %cycle 6036 arg = darg_link 6037 %if arg = 0 %start 6038 error(toomany+point) %if special = 0 6039 get REFERENCE(0) 6040 value = item-ad; !save extra item 6041 %cycle 6042 %if type = realtype %start 6043 %exit %if restype = realtype; !no coercion 6044 %else 6045 %exit %if valok(type,restype) * Failed to analyse line 6045 %EXITIF VALOK(TYPE,RESTYPE) ! * Failed to analyse line 6045 %EXITIF VALOK(TYPE,RESTYPE) ! 6046 %finish 6047 %repeat %until no alt * Failed to analyse line 6047 %REPEATUNTIL NOALT ! * Failed to analyse line 6047 %REPEATUNTIL NOALT ! 6048 special = 0 6049 %else 6050 darg == dict(arg) 6051 %if darg_flags&proc # 0 %start 6052 get(ident) 6053 name error %if item <= 0 6054 fault(typerr+point) %if ditem_flags&proc = 0 %c C %or %not parmatch(darg_type,ditem_type) * Failed to analyse line 6055 FAULT(TYPERR+POINT) %IF DITEM_FLAGS&PROC=0 %ORNOT PARMATCH(DARG_TYPE,DITEM_TYPE) ! * Failed to analyse line 6055 FAULT(TYPERR+POINT) %IF DITEM_FLAGS&PROC=0 %ORNOT PARMATCH(DARG_TYPE,DITEM_TYPE) ! 6056 fault(classerr+point) %if item > headitem %C C %and ditem_mode = procmode {OK if param?} 6058 item = item+ad 6059 put actual 6060 %finish %else %if darg_flags >= 0 %start 6061 jammy = 0 6062 get EXPRESSION(major,0) 6063 %cycle 6064 %exit %if valok(darg_type,type) * Failed to analyse line 6064 %EXITIF VALOK(DARG_TYPE,TYPE) ! * Failed to analyse line 6064 %EXITIF VALOK(DARG_TYPE,TYPE) ! 6065 %repeat %until no alt * Failed to analyse line 6065 %REPEATUNTIL NOALT ! * Failed to analyse line 6065 %REPEATUNTIL NOALT ! 6066 putexp(check,darg_type,item,darg_type) %if jammy # 0 %c C %and control&capbit # 0 %c C %and category(darg_type) < realy 6069 put actual 6070 %else; !name 6071 get REFERENCE(0) 6072 %cycle 6073 %exit %if refok(darg_type,type) * Failed to analyse line 6073 %EXITIF REFOK(DARG_TYPE,TYPE) ! * Failed to analyse line 6073 %EXITIF REFOK(DARG_TYPE,TYPE) ! 6074 %repeat %until no alt * Failed to analyse line 6074 %REPEATUNTIL NOALT ! * Failed to analyse line 6074 %REPEATUNTIL NOALT ! 6075 put actual 6076 tp == typecell(darg_type) 6077 %if tp_flags&cat = arry %c C %and dict(arg+1)_type # darg_type %c C %and tp_mode >= framemode %start 6080 !array name (last in group) with non-literal dope vector 6081 put bounds(darg_type,type) 6082 %finish 6083 %finish 6084 %finish 6085 %repeat %until %not a(comma) * Failed to analyse line 6085 %REPEATUNTILNOT A(COMMA) ! * Failed to analyse line 6085 %REPEATUNTILNOT A(COMMA) ! 6086 error(toofew+point) %if darg_link # 0 %or special # 0 6087 get(right) 6088 %else; !no LEFT * 6088 FAULT 51 %FINISH is not required * 6088 FAULT 51 %FINISH is not required 6089 error(toofew+point) %if darg_link # 0 6090 %finish 6091 put act(pact,hold,0) %if count&1 # 0 %or count = 0 6092 type = restype 6093 %if type # 0 %start; !not routine 6094 %if hp_flags&volatile = 0 %start 6095 p = explo 6096 %while p < explim %cycle 6097 %if dict(p)_act = headitem %start; ![enough?] 6098 item = p; q = procnp 6099 %cycle 6100 %exit %if dict(p)_x # dict(q)_x %or dict(p)_y # dict(q)_y 6101 p = p+1; q = q+1 6102 ->okf %if q >= np 6103 %repeat 6104 %finish 6105 p = p+1 6106 %repeat 6107 %finish 6108 copy down(procnp) 6109 item = explo 6110 okf:ditem == dict(item) 6111 ditem_flags = hp_flags&heritable 6112 ditem_mode = 0 6113 %if hp_flags&writable # 0 %start; !map 6114 ditem_mode = dispmode 6115 %finish 6116 ditem_type = type 6117 np = procnp 6118 %finish 6119 %end; !get PARLIST 6120 6121 !<= 0 6199 arg = darg_hlink 6200 %repeat 6201 fill code(ad+darg_val-cad) 6202 ! [*now OK to code atom*] 6203 %if a(recsub) %start * Failed to analyse line 6203 %IF A(RECSUB) %START ! * Failed to analyse line 6203 %IF A(RECSUB) %START ! 6204 subbed = 1; dformat == fidp 6205 get(ident) 6206 subbed = 0 6207 name error %if item < arg 6208 fill code(ditem_val-darg_val) 6209 arg = item; darg == ditem 6210 syntax error %unless a assop(darg_flags&name+darg_type) * Failed to analyse line 6210 SYNTAXERROR %UNLESS AASSOP(DARG_FLAGS&NAME+DARG_TYPE) ! * Failed to analyse line 6210 SYNTAXERROR %UNLESS AASSOP(DARG_FLAGS&NAME+DARG_TYPE) ! 6211 %finish * 6211 FAULT 59 %FINISH instead of %REPEAT for %CYCLE at line 6193 * 6211 FAULT 59 %FINISH instead of %REPEAT for %CYCLE at line 6193 6212 s = nsize(darg) 6213 %unless a(comma) %start * Failed to analyse line 6213 %UNLESS A(COMMA) %START ! * Failed to analyse line 6213 %UNLESS A(COMMA) %START ! 6214 get VALUE(darg_flags&name+darg_type) 6215 %if s > 0 %start 6216 %if s = 4 %start 6217 !$IF VAX 6218 { value = ieee(value) %if darg_type = realtype %and darg_flags >= 0 6219 !$FINISH 6220 set code longword(value) 6221 %finish %else %if s = 2 %start 6222 set code word(value) 6223 %else 6224 final(cad) <- value; cad = cad+1 6225 %finish 6226 %finish 6227 %exit %if a(right) * Failed to analyse line 6227 %EXITIF A(RIGHT) ! * Failed to analyse line 6227 %EXITIF A(RIGHT) ! 6228 get(comma) 6229 %finish %else %if s > 0 %start * 6229 FAULT 51 %FINISH is not required * 6229 FAULT 51 %FINISH is not required 6230 fill code(s) 6231 %finish 6232 arg = darg_hlink 6233 %repeat * 6233 FAULT 1 %REPEAT is not required * 6233 FAULT 1 %REPEAT is not required 6234 fill code(ad+imod(fidp_val)-cad) 6235 item = 0; value = ad 6236 literal = literal-1 6237 %end 6238 6239 %routine SWOP 6240 %integer temp 6241 temp = item1; item1 = item; item = temp 6242 temp = val1; val1 = value; value = temp 6243 temp = type1; type1 = type; type = temp 6244 %end 6245 6246 %constinteger INTOK=1<>(cat1&cat)&1 = 0 %start 6257 %if cat1 = inty %and ok&realok # 0 %start 6258 toreal; cat1 = realy 6259 %finish %else %if ok&stringok # 0 %and valok(stringtype,type) %start * Failed to analyse line 6259 %FINISHELSEIF OK&STRINGOK#0 %AND VALOK(STRINGTYPE,TYPE) %START ! * Failed to analyse line 6259 %FINISHELSEIF OK&STRINGOK#0 %AND VALOK(STRINGTYPE,TYPE) %START ! 6260 cat1 = stringy 6261 %else 6262 fault(typerr+point) 6263 %finish 6264 %finish * 6264 FAULT 51 %FINISH is not required * 6264 FAULT 51 %FINISH is not required 6265 type1 = type; item1 = item; val1 = value 6266 %end 6267 6268 %integer%fn FROZEN LIT(%integer t,v) 6269 ! Used when the type of a literal will not be recoverable from context 6270 %integer hold,res 6271 hold = item 6272 putexp(move,0,litref(v),t); !NO-OP (distinctive Y) 6273 ditem_flags = okflag+wflag 6274 ditem_mode = constmode; ditem_val = v 6275 res = item; item = hold 6276 %result = res 6277 %end 6278 6279 %routine COERCE(%integer c) 6280 %if c = inty %and cat1 = realy %start 6281 toreal 6282 %finish %else %if cat1 = inty %and c = realy %start 6283 ![rather sloppy] 6284 %if item1 # 0 %start 6285 val1 = item; item = item1 6286 toreal 6287 item1 = item; item = val1 6288 %finish %else real(addr(val1)) = val1 6289 type1 = realtype; cat1 = realy 6290 %else 6291 expfault(typerr) 6292 %finish 6293 %end 6294 6295 %routine GET ARITH(%integer rank) 6296 get EXPRESSION(rank,0) 6297 rank = category(type) 6298 coerce(rank) %if rank # cat1 6299 %end 6300 6301 %integer%fn RCOND(%integer op) 6302 %constinteger EQUAL=2_1001000010, C LESS =2_1010000001, C GREATER=2_0101000001 6305 %integer which,c 6306 !<= 0 6313 double = item 6314 %finish %else %if double < 0 %start 6315 double = -2 6316 %finish 6317 !< 0 %or item1!val1 = 0 %or item!value = 0 %start 6321 !non-structure (compile-time) 6322 ![integer tests ok for real?] 6323 %if val1 < value %then which = less %c C %else %if val1 = value %then which = equal %c C %else which = greater 6326 %result = which>>(op-bne)&1 6327 %finish 6328 item1 = frozen lit(type1,val1) 6329 %else 6330 swop 6331 op = op!!3 %if op&8 # 0; !no change for '=','#' 6332 %finish 6333 %finish 6334 %result = op 6335 %end; !RCOND 6336 !< op(atom) 6345 op(plus): 6346 check1(numok+setok) 6347 get ARITH(star) 6348 %if cat1 = inty %start 6349 %if item1 = 0 %start 6350 %result = val1+value %if item = 0 6351 swop 6352 %finish 6353 %result = nop %if item!value = 0 6354 type = inttype 6355 %result = add 6356 %else 6357 %if item1 = 0 %start 6358 %if item = 0 %start 6359 real(addr(val1)) = real(addr(val1))+real(addr(value)) 6360 %result = val1 6361 %finish 6362 swop 6363 %finish 6364 %result = nop %if item!value = 0 6365 %result = fadd 6366 %finish 6367 op(minus): 6368 check1(numok+setok) 6369 get ARITH(star) 6370 %if cat1 = inty %start 6371 %if item1 = 0 %start 6372 %result = val1-value %if item = 0 6373 swop %and %result = neg %if val1 = 0 6374 %finish 6375 type = inttype 6376 %if item = 0 %start 6377 %result = nop %if value = 0 6378 value = -value %if value # minint 6379 %result = add 6380 %finish 6381 %result = sub 6382 %else 6383 %if item = 0 %start 6384 %if item1 = 0 %start 6385 real(addr(val1)) = real(addr(val1))-real(addr(value)) 6386 %result = val1 6387 %finish 6388 %result = nop %if value = 0 6389 %finish 6390 %result = fsub 6391 %finish 6392 op(exclam): 6393 check1(intok); get EXPRESSION(star,inttype) 6394 %if item1 = 0 %start 6395 %result = val1!value %if item = 0 6396 swop 6397 %finish 6398 %result = nop %if item!value = 0 6399 type = inttype 6400 %result = or 6401 op(exclam2): 6402 check1(intok); get EXPRESSION(star,inttype) 6403 %if item1 = 0 %start 6404 %result = val1!!value %if item = 0 6405 swop 6406 %finish 6407 %result = nop %if item!value = 0 6408 type = inttype 6409 %result = eor 6410 op(ampersand): 6411 check1(intok); get EXPRESSION(star2,inttype) 6412 %if item1 = 0 %start 6413 %result = val1&value %if item = 0 6414 swop 6415 %finish 6416 item1 = 0 %and %result = 0 %if item!value = 0 6417 type = inttype 6418 %result = and 6419 op(star): 6420 check1(numok+setok) 6421 get ARITH(star2) 6422 item1 = 0 %and %result = 0 %if item!value = 0 6423 %if cat1 = inty %start 6424 %if item1 = 0 %start 6425 %result = val1*value %if item = 0 6426 swop 6427 %finish 6428 type = inttype 6429 %result = imul %if control&halfbit = 0 6430 %result = muls 6431 %else 6432 %if item1 = 0 %start 6433 %if item = 0 %start 6434 real(addr(val1)) = real(addr(val1))*real(addr(value)) 6435 %result = val1 6436 %finish 6437 swop 6438 %finish 6439 %result = fmul 6440 %finish 6441 op(over): 6442 check1(intok); get EXPRESSION(star2,inttype) 6443 %if item = 0 %start 6444 fault(rangerr) %and %result = nop %if value = 0 6445 %result = val1//value %if item1 = 0 6446 %finish 6447 type = inttype 6448 %result = idiv 6449 op(slash): 6450 check1(realok) 6451 get EXPRESSION(star2,realtype) 6452 %if item = 0 %start 6453 fault(rangerr) %and %result = nop %if value = 0 6454 %if item1 = 0 %start 6455 real(addr(val1)) = real(addr(val1))/real(addr(value)) 6456 %result = val1 6457 %finish 6458 %finish 6459 %result = fdiv 6460 op(backslash2): op(uparrow2): 6461 check1(intok); get EXPRESSION(simple,inttype) 6462 %if item = 0 %start 6463 %result = val1\\value %if item1 = 0 6464 item1 = 0 %and %result = 1 %if value = 0 6465 %result = nop %if value = 1 6466 item = item1 %and %result = imul %if value = 2 6467 %finish 6468 type = inttype 6469 %result = ipow 6470 op(backslash): op(uparrow): op(star2): 6471 check1(realok) 6472 get EXPRESSION(simple,inttype) 6473 type = realtype 6474 %if item!item1 = 0 %start 6475 real(addr(val1)) = real(addr(val1))\value 6476 %result = val1 6477 %finish 6478 %result = fpow 6479 op(lshift): 6480 check1(intok); get EXPRESSION(simple,inttype) 6481 %if item = 0 %start 6482 %result = val1<>value %if item1 = 0 6491 %result = nop %if value = 0 6492 %finish 6493 type = inttype 6494 %result = lsr 6495 op(tilde): 6496 check1(intok) 6497 get EXPRESSION(simple,inttype) 6498 %result = \value %if item = 0 6499 swop 6500 type = inttype 6501 %result = not 6502 op(sconc): 6503 check1(stringok); get EXPRESSION(dot+1,stringtype) 6504 %if item = 0 %start 6505 %if item1 = 0 %start 6506 %result = val1 %if value = 0 6507 %result = value %if val1 = 0 6508 %if final(val1)+final(value) <= 255 %start 6509 string(final0+val1) = string(final0+val1) %c C . string(final0+value) 6511 cad = cad-1 6512 %finish %else fault(rangerr) 6513 %result = val1 6514 %finish 6515 %result = nop %if value = 0 6516 %finish %else %if item1!val1 = 0 %start 6517 item1 = item; val1 = value; type1 = type 6518 %result = nop 6519 %finish 6520 type = stringtype 6521 %result = concat 6522 op(equals): 6523 %result = RCOND(beq) 6524 op(noteq): 6525 %result = RCOND(bne) 6526 op(lesseq): 6527 %result = RCOND(ble) 6528 op(less): 6529 %result = RCOND(blt) 6530 op(greateq): 6531 %result = RCOND(bge) 6532 op(greater): 6533 %result = RCOND(bgt) 6534 %integer%fn RACOND(%integer op) 6535 toref 6536 item1 = normitem; type1 = type 6537 get REFERENCE(type1) 6538 val1 = 0 %and swop %if item1 = 0 6539 syntax error %if arrow <= atom <= greater; ![ATOM always primed] 6540 double = -2 6541 %result = op 6542 %end 6543 op(eqeq): 6544 %result = RACOND(beq) 6545 op(noteqeq): 6546 %result = RACOND(bne) 6547 op(arrow): 6548 check1(stringok) 6549 item1 = litref(val1) %if item1 = 0 6550 get RESOLUTION(type,item1) 6551 item1 = np-3 6552 condop = bne!!polarity 6553 type1 = booltype 6554 %result = nop 6555 op(keyand): 6556 topred %if condop = 0 6557 item1 = np; type1 = booltype 6558 putact(condop!!polarity!!1+polarity<<7,item,0) 6559 condop = 0 6560 get EXPRESSION(scond,booltype) 6561 dict(item1)_y = item 6562 syntax error %if a(keyor) * Failed to analyse line 6562 SYNTAXERROR %IF A(KEYOR) ! * Failed to analyse line 6562 SYNTAXERROR %IF A(KEYOR) ! 6563 %result = nop 6564 op(keyor): 6565 topred %if condop = 0 6566 item1 = np; type1 = booltype 6567 putact(condop!!polarity+(polarity!!1)<<7,item,0) 6568 condop = 0 6569 get EXPRESSION(scond,booltype) 6570 dict(item1)_y = item 6571 syntax error %if a(keyand) * Failed to analyse line 6571 SYNTAXERROR %IF A(KEYAND) ! * Failed to analyse line 6571 SYNTAXERROR %IF A(KEYAND) ! 6572 %result = nop 6573 %end 6574 6575 !Get leading operand 6576 atom = next atom %if matched # 0 6577 atomp0 = atomp; jammy = jammy<<1; !preserve 6578 %if atom = ident %start 6579 matched = 1 6580 name error %if item <= 0 %or (ditem_mode = labmode %and item < c_localdpos) 6581 fault(namerr+point) %if item >= dlim0 6582 type = ditem_type 6583 %if ditem_flags&typeid # 0 %start 6584 %if ditem_flags&cat = recy %and item > dnil %start 6585 get RECORD 6586 %return 6587 %else 6588 item1 = item; ditem1 == ditem 6589 %if a(less) %start; !type coercion * Failed to analyse line 6589 %IF A(LESS) %START ; ! * Failed to analyse line 6589 %IF A(LESS) %START ; ! 6590 get VALUE(0); get(greater) 6591 type = item1 6592 %else 6593 get(left); !store mapping 6594 get VALUE(inttype) 6595 get(right) 6596 putexp2(storemap,item1,item1) 6597 ditem_flags = writable!readable 6598 ditem_mode = dispmode 6599 %finish 6600 %finish 6601 %finish %else %if ditem_mode = litmode %start 6602 item = 0; value = ditem_val 6603 %else; !non-literal ident 6604 %cycle 6605 %if ditem_flags&proc # 0 %start 6606 %if item = daddr %or item = dsizeof %or item = dnew %start 6607 get(left) 6608 %if item = daddr %start 6609 get REFERENCE(0) 6610 type = inttype 6611 %else 6612 item1 = item 6613 get REFERENCE(0) 6614 value = imod(size(type)) 6615 expfault(sizerr) %if value = 0 6616 %if item1 = dsizeof %start 6617 item = 0; type = inttype 6618 %else 6619 putexp(dnew,0,litref(value),0) 6620 ditem_mode = dispmode 6621 %finish 6622 %finish 6623 get(right) 6624 ! %finish %else %if item = dsnl %start 6625 ! putexp(dtostring,nl,0,string1) 6626 %else 6627 get PARLIST(0) 6628 atomp=atomp0 %and error(classerr+point) %if type = 0; !routine 6629 %finish 6630 %else; !not procedure 6631 atom = next atom %if matched # 0 6632 %exit %unless aleft <= atom <= recsub %and rank <= simple 6633 %if atom = aleft %start; !array subscript 6634 %cycle 6635 item1 = item; ditem1 == ditem 6636 tp == typecell(type) 6637 %if tp_flags&cat = stringy %start 6638 matched = 1 6639 nonstandard(2) 6640 get VALUE(bytetype) 6641 putexp2(sindex,item1,chartype) 6642 %else 6643 -> out %unless tp_flags&cat = arry 6644 matched = 1 6645 get VALUE(tp_xtype); !get index 6646 putexp2(index,item1,tp_type) 6647 %finish 6648 ditem_flags = ditem1_flags&heritable 6649 ditem_mode = ditem1_mode 6650 %repeat %until %not a(comma) * Failed to analyse line 6650 %REPEATUNTILNOT A(COMMA) ! * Failed to analyse line 6650 %REPEATUNTILNOT A(COMMA) ! 6651 ditem_flags = ditem_flags+(tp_flags&name) 6652 get(right) 6653 %finish %else %if atom = recsub %start; !record subfield 6654 item1 = item; ditem1 == ditem 6655 dformat == typecell(ditem_type) 6656 syntax error %unless dformat_flags&cat = recy 6657 matched = 1 6658 subbed = 1; get(ident); subbed = 0 6659 error(namerr+point) %if item <= 0 6660 val1 = ditem1_flags&heritable!ditem_flags 6661 putexp2(recref,item1,ditem_type) 6662 ditem_flags = val1 6663 ditem_mode = ditem1_mode 6664 %finish %else %if atom = atsign %start 6665 nonstandard(4) 6666 syntax error %if ditem_flags&typeid = 0 6667 matched = 1 6668 ditem1 == ditem; item1 = item 6669 get EXPRESSION(vsimple,inttype) 6670 putexp2(storemap,item1,item1) 6671 ditem_flags = writable!readable 6672 ditem_mode = dispmode 6673 %else; !pointer relative 6674 error(nonref+point) %if ditem_mode < dispmode 6675 fault(sizerr) %if size(ditem_type) = 0 6676 matched = 1 6677 ditem1 == ditem; item1 = item 6678 get VALUE(inttype); get(rightb) 6679 putexp2(prel,item1,ditem1_type) 6680 ditem_flags = writable!readable 6681 ditem_mode = ditem1_mode 6682 %finish 6683 %finish 6684 %repeat 6685 %finish 6686 %else * 6686 FAULT 51 %FINISH is not required * 6686 FAULT 51 %FINISH is not required 6687 %if atom = const %start 6688 matched = 1 6689 %finish %else %if atom = minus %start; !leave unmatched 6690 item = 0; value = 0; type = inttype 6691 %finish %else %if atom = left %start 6692 matched = 1 6693 %if rank < major %start; !condition 6694 get EXPRESSION(condq,0) 6695 %else 6696 get EXPRESSION(major,0) 6697 %finish 6698 get(right) 6699 %finish %else %if a(keynot) %start * Failed to analyse line 6699 %FINISHELSEIF A(KEYNOT) %START ! * Failed to analyse line 6699 %FINISHELSEIF A(KEYNOT) %START ! 6700 syntax error %if rank >= major 6701 polarity = polarity!!1 6702 get EXPRESSION(scond,booltype) 6703 %if item = 0 %then value = value!!1 6704 polarity = polarity!!1 6705 %finish %else %if atom = backslash %start 6706 item = 0; value = 0; type = inttype 6707 atom = tilde 6708 %finish %else %if a(modsign) %start * Failed to analyse line 6708 %FINISHELSEIF A(MODSIGN) %START ! * Failed to analyse line 6708 %FINISHELSEIF A(MODSIGN) %START ! 6709 get EXPRESSION(major,0) 6710 %if valok(inttype,type) %start * Failed to analyse line 6710 %IF VALOK(INTTYPE,TYPE) %START ! * Failed to analyse line 6710 %IF VALOK(INTTYPE,TYPE) %START ! 6711 %if item = 0 %start 6712 %if value < 0 %start 6713 %if value # minint %then value = -value %else expfault(rangerr) 6714 %finish 6715 %else 6716 putexp2(iabs,0,inttype) 6717 %finish 6718 %finish %else %if valok(realtype,type) %start * 6718 FAULT 51 %FINISH is not required * 6718 FAULT 51 %FINISH is not required * Failed to analyse line 6718 %FINISHELSEIF VALOK(REALTYPE,TYPE) %START ! * Failed to analyse line 6718 %FINISHELSEIF VALOK(REALTYPE,TYPE) %START ! 6719 putexp2(fabs,0,realtype) 6720 %else * 6720 FAULT 51 %FINISH is not required * 6720 FAULT 51 %FINISH is not required 6721 error(typerr+point) 6722 %finish 6723 get(modsign) 6724 %else * 6724 FAULT 51 %FINISH is not required * 6724 FAULT 51 %FINISH is not required 6725 syntax error 6726 %finish 6727 %finish * 6727 FAULT 51 %FINISH is not required * 6727 FAULT 51 %FINISH is not required 6728 out: 6729 atom = next atom %if matched # 0; ![always primed on return] 6730 6731 %if etype < 0 %start; !reference required 6732 expp = atomp0; jammy = jammy>>1; !restore 6733 %unless item!value = 0 %start; !*temp* 6734 toref 6735 expfault(typerr) %unless refok(etype-sign16,type) * Failed to analyse line 6735 EXPFAULT(TYPERR) %UNLESS REFOK(ETYPE-SIGN16,TYPE) ! * Failed to analyse line 6735 EXPFAULT(TYPERR) %UNLESS REFOK(ETYPE-SIGN16,TYPE) ! 6736 %finish %else atomp = atomp0 %and nonstandard(21) 6737 %else 6738 %while atom >= rank %cycle 6739 matched = 1 6740 double = -1 6741 op = opval 6742 %if item1!item = 0 %start; !both literal 6743 %if double # -1 %start 6744 %if double >= 0 %start 6745 literal = literal+1; !enforce all literal 6746 op = op&opval 6747 literal = literal-1 6748 %finish 6749 type = booltype 6750 %finish 6751 value = op 6752 %finish %else %if double = -1 %start; !not relop 6753 %if op # 0 %start 6754 item1 = litref(val1) %if item1 = 0 6755 putexp(op,item1,normitem,type) 6756 %else; !nop 6757 item = item1; type = type1 6758 %finish 6759 %else; !conditional operation 6760 condop = op!!polarity 6761 putact(compare,item1,normitem) 6762 item = np-1 6763 %if double >= 0 %start 6764 putact(condop!!polarity!!1+polarity<<7,np-1,np+1); !implicit %and 6765 item = double; ![TYPE,VALUE unchanged] 6766 matched = 1 6767 op = opval 6768 error(nonliteral) %if item1!item = 0; !mixed non-lit, lit 6769 condop = op!!polarity 6770 putact(compare,item1,normitem) 6771 item = np-2 6772 %finish 6773 type = booltype 6774 %finish 6775 %repeat 6776 expp = atomp0; jammy = jammy>>1 6777 %if etype # 0 %start 6778 %if type = booltype %start 6779 topred %if (rank = cond %or rank = scond) %and condop = 0 6780 %finish 6781 expfault(typerr) %unless valok(etype,type) * Failed to analyse line 6781 EXPFAULT(TYPERR) %UNLESS VALOK(ETYPE,TYPE) ! * Failed to analyse line 6781 EXPFAULT(TYPERR) %UNLESS VALOK(ETYPE,TYPE) ! 6782 %finish 6783 %finish 6784 atomp=expp %and error(nonliteral+point) %if literal # 0 %and item # 0 6785 %end; !get EXPRESSION 6786 6787 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 6788 !!!!!!!!!!!!!!!!!!!! Conditions and loops !!!!!!!!!!!!!!!!!!!! 6789 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 6790 ! 6791 %routine GET CONDITION 6792 %integer maxlab,condnp 6793 6794 %routine ASSIGN LABELS(%integer p,lab,pol) 6795 %integer base=maxlab * Failed to analyse line 6795 %INTEGER BASE=MAXLAB ! * Failed to analyse line 6795 %INTEGER BASE=MAXLAB ! 6796 %record(identinfo)%name dp 6797 %while (p-condnp)&1 # 0 %cycle; !compound 6798 dp == dict(p); p = dp_y 6799 %if dp_act&1<<7 = pol %then assign labels(dp_x,lab,pol) %c C %else maxlab = base+1 %and assign labels(dp_x,maxlab,pol!!1<<7) 6801 %repeat 6802 dp == dict(p+1); dp == dp[2] %if dp_act = 0; !resolution * Failed to analyse line 6802 DP==DP[2] %IF DP_ACT=0; ! * Failed to analyse line 6802 DP==DP[2] %IF DP_ACT=0; ! 6803 %if maxlab > base %then dp_x = maxlab %and maxlab = base %c C %else dp_x = 0 6805 dp_y = lab 6806 dp_act = dp_act&127 6807 %end 6808 6809 condnp = np 6810 polarity = subatom; condop = 0 6811 get EXPRESSION(cond,booltype) 6812 putact(condop!!1,item,0) 6813 %return %if faultnum > 0 6814 maxlab = curlab+1 6815 assign labels(item,maxlab,0) 6816 %end; !get CONDITION 6817 6818 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 6819 6820 %routine DO DYNAMIC ARRAYS 6821 update sp 6822 c_mode = c_mode!2_01000000; !bar to SP rel addressing 6823 c_status = c_status!globbed; !needs link 6824 %while c_dynarray # 0 %cycle 6825 %if c_dynarray < 0 %then putact(aget,-c_dynarray,one) %c C %else putact(aget,c_dynarray,0) 6827 c_dynarray = dict(imod(c_dynarray))_link 6828 %repeat 6829 compile(np0) 6830 %end 6831 6832 %routine GET STATEMENTS(%integer stopper) 6833 ! STOPPER = 0 -- initial call 6834 ! 1 (END) -- for procedure or block body 6835 ! 2 (REPEAT) -- for loop body 6836 ! 3 (FINISH) -- for condition body (ELSE not valid) 6837 ! 4 (ELSE) -- " (ELSE valid) 6838 %switch initial(0:atommax) 6839 %integer forinf,endval,loopstart 6840 6841 %routine THIS IS INST 6842 %if c_status < hadinst %start; !first in block 6843 c_status = c_status+hadinst 6844 fault(ordererr) %if stopper = 0 6845 %finish 6846 fault(accesserr+warn) %if c_access = 0 %and np = np0 6847 do dynamic arrays %if c_dynarray # 0 6848 %end 6849 6850 %routine PUTACT2(%integer act,item1) 6851 putact(act,item1,normitem) 6852 %end 6853 6854 %routine GET RESULT 6855 get VALUE(c_type) 6856 ! fault(rangerr+warn) %if c_type > 0 %and item # 0 %c C ! %and imod(size(type)) > imod(size(c_type)) 6858 %end 6859 6860 %routine GET INSTRUCTION 6861 %integer item1 6862 %record(identinfo)%name tp 6863 this is inst 6864 %cycle 6865 %if a(ident) %start * Failed to analyse line 6865 %IF A(IDENT) %START ! * Failed to analyse line 6865 %IF A(IDENT) %START ! 6866 name error %if item <= 0 6867 %if ditem_flags&(writable!typeid) # 0 %start 6868 matched = 0 6869 get EXPRESSION(simple,0) 6870 item1 = item 6871 %if a(equals) %start * Failed to analyse line 6871 %IF A(EQUALS) %START ! * Failed to analyse line 6871 %IF A(EQUALS) %START ! 6872 jammy = 0 6873 get VALUE(type) 6874 putact2(okass+jammy,item1); !okass,assign 6875 %finish %else %if a(eqeq) %start * Failed to analyse line 6875 %FINISHELSEIF A(EQEQ) %START ! * Failed to analyse line 6875 %FINISHELSEIF A(EQEQ) %START ! 6876 syntax error %if ditem_flags >= 0 6877 get REFERENCE(type) 6878 putact2(assign,item1+ad) 6879 %finish %else %if atom = less %and byteintegeR(fp) = '-' %start * 6879 FAULT 59 %FINISH instead of %REPEAT for %CYCLE at line 6864 * 6879 FAULT 59 %FINISH instead of %REPEAT for %CYCLE at line 6864 6880 fp = fp+1; matched = 1 6881 jammy = 1 6882 get VALUE(type) 6883 putact2(jamass+jammy,item1); !jamass,okass 6884 %else 6885 syntax error %unless a(arrow) * Failed to analyse line 6885 SYNTAXERROR %UNLESS A(ARROW) ! * Failed to analyse line 6885 SYNTAXERROR %UNLESS A(ARROW) ! 6886 get RESOLUTION(type,item1) 6887 putact(bne,0,curlab) 6888 putact(signal,litref(7),undef) 6889 putact(0,undef,undef) 6890 %finish 6891 %else * 6891 FAULT 51 %FINISH is not required * 6891 FAULT 51 %FINISH is not required 6892 error(classerr+point) %if ditem_flags&proc = 0 6893 tp == typecell(ditem_type) 6894 %if tp_type # 0 %start; !function as routine 6895 get PARLIST(tp_type) 6896 putact2(assign,value) 6897 %else 6898 get PARLIST(0) 6899 %finish 6900 %finish 6901 %else * 6901 FAULT 51 %FINISH is not required * 6901 FAULT 51 %FINISH is not required 6902 c_access = 0 %if np = np0; !unconditional 6903 %if a(keymonitor) %start * Failed to analyse line 6903 %IF A(KEYMONITOR) %START ! * Failed to analyse line 6903 %IF A(KEYMONITOR) %START ! 6904 c_access = 1 6905 ! fault(monitor<<8) 6906 %finish %else %if a(exit) %start; !%exit, %continue * Failed to analyse line 6906 %FINISHELSEIF A(EXIT) %START ; ! * Failed to analyse line 6906 %FINISHELSEIF A(EXIT) %START ; ! 6907 %if c_looplab = 0 %then fault(notinloop+point) %c C %else putact(jumpout,c_looplab,c_looplab+subatom) 6909 %exit 6910 %finish %else %if a(keyreturn) %start * 6910 FAULT 51 %FINISH is not required * 6910 FAULT 51 %FINISH is not required * Failed to analyse line 6910 %FINISHELSEIF A(KEYRETURN) %START ! * Failed to analyse line 6910 %FINISHELSEIF A(KEYRETURN) %START ! 6911 item = 0; value = 0 6912 get RESULT %if c_type # 0 6913 putact2(return,0) 6914 %exit 6915 %finish %else %if a(keyresult) %start * 6915 FAULT 51 %FINISH is not required * 6915 FAULT 51 %FINISH is not required * Failed to analyse line 6915 %FINISHELSEIF A(KEYRESULT) %START ! * Failed to analyse line 6915 %FINISHELSEIF A(KEYRESULT) %START ! 6916 error(notinfun+point) %if c_type = 0 6917 syntax error %unless a assop(c_type) * Failed to analyse line 6917 SYNTAXERROR %UNLESS AASSOP(C_TYPE) ! * Failed to analyse line 6917 SYNTAXERROR %UNLESS AASSOP(C_TYPE) ! 6918 get RESULT 6919 putact2(return,0) 6920 %exit 6921 %finish %else %if a(tf) %start; !%true, %false * 6921 FAULT 51 %FINISH is not required * 6921 FAULT 51 %FINISH is not required * Failed to analyse line 6921 %FINISHELSEIF A(TF) %START ; ! * Failed to analyse line 6921 %FINISHELSEIF A(TF) %START ; ! 6922 %if c_type # booltype %then fault(notinpred+point) %c C %else putact(return,0,litref(subatom)) 6924 %exit 6925 %finish %else %if a(arrow) %or a(keygoto) %start * 6925 FAULT 51 %FINISH is not required * 6925 FAULT 51 %FINISH is not required * Failed to analyse line 6925 %FINISHELSEIF A(ARROW) %OR A(KEYGOTO) %START ! * Failed to analyse line 6925 %FINISHELSEIF A(ARROW) %OR A(KEYGOTO) %START ! 6926 nonstandard(5) %if atom = keygoto 6927 get(ident) 6928 %if byteinteger(fp) # '(' %start 6929 declare(forwardlabel) %if item < c_localdpos {new} %c C %or ditem_type # 0 {error} 6931 putact2(goto,0) 6932 %else 6933 name error %if item < c_localdpos 6934 error(classerr+point) %unless ditem_mode = labmode %c C %and ditem_type # 0 6936 item1 = item 6937 get(left) 6938 get VALUE(typecell(ditem_type)_xtype); !index 6939 get(right) 6940 putact2(swgoto,item1) 6941 %finish 6942 %exit 6943 %finish %else %if a(keystop) %start * 6943 FAULT 51 %FINISH is not required * 6943 FAULT 51 %FINISH is not required * Failed to analyse line 6943 %FINISHELSEIF A(KEYSTOP) %START ! * Failed to analyse line 6943 %FINISHELSEIF A(KEYSTOP) %START ! 6944 putact(stop,0,0) 6945 %exit 6946 %finish %else %if a(keysignal) %start * 6946 FAULT 51 %FINISH is not required * 6946 FAULT 51 %FINISH is not required * Failed to analyse line 6946 %FINISHELSEIF A(KEYSIGNAL) %START ! * Failed to analyse line 6946 %FINISHELSEIF A(KEYSIGNAL) %START ! 6947 c_access = 1 6948 allow(keyevent) 6949 get LITERAL(inttype) 6950 expfault(rangerr) %unless 0 <= value <= 15 6951 item1 = litref(value); item = undef 6952 %if a(comma) %start * Failed to analyse line 6952 %IF A(COMMA) %START ! * Failed to analyse line 6952 %IF A(COMMA) %START ! 6953 l1: %if a(comma) %then matched = 0 %else get VALUE(bytetype) * Failed to analyse line 6953 %IF A(COMMA) %THEN MATCHED=0 %ELSE GETVALUE(BYTETYPE) ! * Failed to analyse line 6953 %IF A(COMMA) %THEN MATCHED=0 %ELSE GETVALUE(BYTETYPE) ! 6954 %finish * 6954 FAULT 51 %FINISH is not required * 6954 FAULT 51 %FINISH is not required 6955 putact2(signal,item1) 6956 item = undef 6957 %if a(comma) %start * Failed to analyse line 6957 %IF A(COMMA) %START ! * Failed to analyse line 6957 %IF A(COMMA) %START ! 6958 l2: %if a(comma) %then matched = 0 %else get VALUE(inttype) * Failed to analyse line 6958 %IF A(COMMA) %THEN MATCHED=0 %ELSE GETVALUE(INTTYPE) ! * Failed to analyse line 6958 %IF A(COMMA) %THEN MATCHED=0 %ELSE GETVALUE(INTTYPE) ! 6959 %finish * 6959 FAULT 51 %FINISH is not required * 6959 FAULT 51 %FINISH is not required 6960 item1 = normitem; item = undef 6961 get VALUE(stringtype) %if a(comma) * Failed to analyse line 6961 GETVALUE(STRINGTYPE) %IF A(COMMA) ! * Failed to analyse line 6961 GETVALUE(STRINGTYPE) %IF A(COMMA) ! 6962 putact2(0,item1) 6963 %exit 6964 %else * 6964 FAULT 51 %FINISH is not required * 6964 FAULT 51 %FINISH is not required 6965 syntax error 6966 %finish 6967 %finish * 6967 FAULT 51 %FINISH is not required * 6967 FAULT 51 %FINISH is not required 6968 %repeat %until %not a(keyand) * 6968 FAULT 1 %REPEAT is not required * 6968 FAULT 1 %REPEAT is not required * Failed to analyse line 6968 %REPEATUNTILNOT A(KEYAND) ! * Failed to analyse line 6968 %REPEATUNTILNOT A(KEYAND) ! 6969 %end; !GET INSTRUCTION 6970 6971 %routine GET FOR CLAUSE 6972 !Global: FORINF,ENDVAL 6973 %integer loopvar,lvtype,k,s,start,sval,i,inc,ival,e,n 6974 %integer end 6975 %record(identinfo)%name tp 6976 forinf = 0 6977 get(ident) 6978 name error %if item <= 0 6979 lvtype = ditem_type; tp == typecell(lvtype) 6980 fault(typerr+point) %if tp_flags&nonord # 0 6981 loopvar = item 6982 get(equals) 6983 get VALUE(lvtype) 6984 start = item; sval = value 6985 get(comma) 6986 get VALUE(lvtype) 6987 inc = item; ival = value 6988 expfault(rangerr) %and ival = 1 %if inc = 0 = ival 6989 !Deal with INC and replace START by START-INC 6990 k = undef 6991 k = dict(start)_y %if start >= np0 %and dict(start)_act = add 6992 %if inc = 0 %start; !literal increment 6993 i = litref(ival) 6994 %if start = 0 %start; !START and INC both literal 6995 sval = sval-ival; item = litref(sval) 6996 %finish %else %if k <= 0 %start; !START is x+lit 6997 k = litval(k)-ival 6998 item = dict(start)_x 6999 putexp(add,item,litref(k),inttype) %if k # 0 7000 %else 7001 putexp(add,start,litref(-ival),inttype) 7002 %finish 7003 %else; !variable 7004 i = inc 7005 %if control&volbit # 0 %start 7006 declare temp(inttype); i = item 7007 putact(assign,i,inc); forinf = forinf-4 7008 %finish 7009 %if start = inc %start; !identical 7010 item = 0; sval = 0 7011 %finish %else %if k = inc %start; !START is x+INC 7012 item = dict(start)_x 7013 %else 7014 item = start; item = litref(sval) %if item = 0 7015 putexp(sub,item,i,inttype) 7016 %finish 7017 %finish 7018 s = item 7019 !Get end-value 7020 get(comma) 7021 get VALUE(lvtype) 7022 end = item 7023 %if end = 0 %start; !literal end-value 7024 e = litref(value); endval = value 7025 %else 7026 e = item 7027 %if control&volbit # 0 %start 7028 declare temp(inttype); e = item 7029 putact(assign,e,end); forinf = forinf-4 7030 %finish 7031 %finish 7032 %if start!inc!end # 0 %and control&loopbit # 0 %start 7033 putact(forass,loopvar,s) 7034 putact(forass,i,e) 7035 %else 7036 putact(assign,loopvar,s) 7037 %finish 7038 putact(label,curlab,0) 7039 %if start!inc!end = 0 %start; !all literal 7040 k = endval-sval; n = k//ival 7041 %if n = 0 %start 7042 fault(dubious+warn) 7043 putact(else,0,curlab+1); !ie unconditional branch 7044 %return 7045 %finish 7046 fault(boundserr) %if n < 0 7047 fault(unending) %if n*ival # k 7048 forinf = loopvar 7049 %else 7050 putact(compare,loopvar,e) 7051 putact(beq,0,curlab+1) 7052 %finish 7053 putact(incass,loopvar,i) 7054 %end; !get FORCLAUSE 7055 7056 %routine GET LOOP BODY 7057 %integer hold=c_looplab * Failed to analyse line 7057 %INTEGER HOLD=C_LOOPLAB ! * Failed to analyse line 7057 %INTEGER HOLD=C_LOOPLAB ! 7058 c_looplab = curlab; curlab = curlab+2 7059 get STATEMENTS(keyrepeat) 7060 curlab = curlab-2; c_looplab = hold 7061 %end 7062 7063 %routine GET SWITCH INDEX 7064 %integer i,lo,hi 7065 %record(identinfo)%name dp,tp 7066 %routine SET LABEL(%shortname p) 7067 value = p 7068 expfault(duperr) %if value > 0 7069 set user label(value) 7070 p = value 7071 %end 7072 dp == ditem; tp == typecell(ditem_type) 7073 get(left) 7074 %if a(star) %start * Failed to analyse line 7074 %IF A(STAR) %START ! * Failed to analyse line 7074 %IF A(STAR) %START ! 7075 set label(dp_link) 7076 %else * 7076 FAULT 51 %FINISH is not required * 7076 FAULT 51 %FINISH is not required 7077 get VALUE(tp_xtype) 7078 !beware faulty declaration or index 7079 %if tp_xtype > inttype %and faultnum = 0 %start 7080 get bounds(tp_xtype,lo,hi) 7081 i = value-lo+dp_val 7082 c_forward = c_forward-1 %if i < pc; !(had goto) 7083 set label(prog(i)) 7084 %finish 7085 %finish 7086 get(right) 7087 %end 7088 7089 ![unsure of efficiency implications of trapping overflow lower down] 7090 %on %event oflow,fail,done %start 7091 %if event_event = 0 %start; !failure in %option,%include or ^Y 7092 %stop %if event_sub # 0 7093 %signal abandon 7094 %finish 7095 %if event_event = done %start 7096 croak("Premature end of input") %if stopper # 0 7097 close block 7098 c_dpid_val = 0; !zero entry-point 7099 %return 7100 %finish 7101 fault(rangerr+now) %if event_event = oflow 7102 -> ignore 7103 %finish 7104 !!!!!!!!!!!!!!!!!!! Start of new statement !!!!!!!!!!!!!!!!!!! 7105 next: 7106 statements = statements+1 7107 compile(startnp) %if np > np0 7108 define label(curlab) %if dict(curlab)_val < 0 7109 define label(curlab+1) %if dict(curlab+1)_val < 0 7110 next1: 7111 report(faultnum,0,0) %if faultnum # 0 7112 dlim0 = dlim 7113 speccing = 0; subbed = 0 7114 literal = 0; jammy = 0; condop = 0 7115 dict(curlab)_val = 0; dict(curlab+1)_val = 0 7116 np = np0; startnp = np0 7117 maxcalldreg = maxdreg; maxcallareg = maxareg 7118 zaps = zaps+1 %and forget all %if explo < np0+50 7119 zaps = zaps+1000 %and forget all %if litpos > litmax-40 7120 value = 0 7121 ! 7122 initial(terminator): 7123 atom = next atom; matched = 1 7124 -> initial(atom) 7125 7126 initial(keycomment): initial(exclam): initial(exclam2): 7127 comments = comments+1 7128 read line(0) 7129 -> next1 7130 term: 7131 get(terminator) 7132 -> next 7133 7134 ignore: 7135 c_access = -1 7136 %if atom # terminator %start 7137 %cycle 7138 subatom = atom; atom = next atom 7139 %repeat %until atom = terminator 7140 starts = starts+1 %if subatom = keystart 7141 cycles = cycles+1 %if subatom = keycycle 7142 %finish 7143 -> next1 7144 7145 initial(dud): 7146 syntax error; !ie atom error 7147 7148 initial(*): 7149 error(nonstarter+point) 7150 7151 initial(ident): 7152 %if byteintegeR(fp) = ':' %start; !simple label 7153 fp = fp+1 7154 declare(definedlabel) 7155 set user label(ditem_val) 7156 ->next 7157 %finish 7158 name error %if item <= 0 7159 %if ditem_mode = labmode %and ditem_type # 0 %start 7160 literal = 1 7161 get SWITCH INDEX 7162 get(colon) 7163 ->next 7164 %finish 7165 initial(keyreturn): initial(keyresult): initial(tf): 7166 initial(keystop): initial(keysignal): initial(keymonitor): 7167 initial(exit): initial(keygoto): initial(arrow): 7168 matched = 0 7169 get INSTRUCTION 7170 -> next %if a(terminator) * Failed to analyse line 7170 ->NEXT %IF A(TERMINATOR) ! * Failed to analyse line 7170 ->NEXT %IF A(TERMINATOR) ! 7171 c_access = 1 7172 %if a(iu) %start * Failed to analyse line 7172 %IF A(IU) %START ! * Failed to analyse line 7172 %IF A(IU) %START ! 7173 startnp = np 7174 get CONDITION 7175 %finish %else %if a(keywhile) %start * 7175 FAULT 51 %FINISH is not required * 7175 FAULT 51 %FINISH is not required * Failed to analyse line 7175 %FINISHELSEIF A(KEYWHILE) %START ! * Failed to analyse line 7175 %FINISHELSEIF A(KEYWHILE) %START ! 7176 {GT: continue fixing else if's from here...} 7177 putact(repeat,curlab,0); !append repeat 7178 startnp = np 7179 define label(curlab) 7180 get CONDITION 7181 %else %if a(keyfor) * 7181 FAULT 51 %FINISH is not required * 7181 FAULT 51 %FINISH is not required * Failed to analyse line 7181 %ELSEIF A(KEYFOR) ! * Failed to analyse line 7181 %ELSEIF A(KEYFOR) ! 7182 putact(0,0,0) 7183 putact(0,0,0) 7184 putact(repeat,curlab,0); !append repeat 7185 startnp = np 7186 get FOR CLAUSE 7187 value = np; np = startnp-3 7188 %if forinf > 0 %start 7189 putact(compare,forinf,litref(endval)) 7190 putact(beq,0,curlab) 7191 %finish %else np = np+2 7192 putact(repeat,curlab,forinf) 7193 np = value 7194 %else 7195 syntax error %unless a(keyuntil) * Failed to analyse line 7195 SYNTAXERROR %UNLESS A(KEYUNTIL) ! * Failed to analyse line 7195 SYNTAXERROR %UNLESS A(KEYUNTIL) ! 7196 get CONDITION 7197 putact(repeat,curlab,0) 7198 define label(curlab) 7199 %finish 7200 -> term 7201 7202 initial(iu): !%if, %unless 7203 this is inst 7204 %cycle 7205 get CONDITION 7206 %if a(keythen) %and %not a(keystart) %start * Failed to analyse line 7206 %IF A(KEYTHEN) %ANDNOT A(KEYSTART) %START ! * Failed to analyse line 7206 %IF A(KEYTHEN) %ANDNOT A(KEYSTART) %START ! 7207 get INSTRUCTION 7208 %else * 7208 FAULT 59 %FINISH instead of %REPEAT for %CYCLE at line 7204 * 7208 FAULT 59 %FINISH instead of %REPEAT for %CYCLE at line 7204 7209 matched = 0; ![unsee %start] 7210 get(keystart) 7211 %cycle 7212 get(terminator) 7213 curlab = curlab+2 7214 get STATEMENTS(keyelse) 7215 curlab = curlab-2 7216 %exit %if atom # keyelse; !%finish -> 7217 putact(else,curlab+1,curlab) 7218 -> exit2 %unless a(iu) * Failed to analyse line 7218 ->EXIT2 %UNLESS A(IU) ! * Failed to analyse line 7218 ->EXIT2 %UNLESS A(IU) ! 7219 get CONDITION 7220 %repeat 7221 -> initial(keyend) %if atom = keyend 7222 %finish 7223 -> term %unless a(keyelse) * Failed to analyse line 7223 ->TERM %UNLESS A(KEYELSE) ! * Failed to analyse line 7223 ->TERM %UNLESS A(KEYELSE) ! 7224 putact(else,curlab+1,curlab) 7225 %repeat %until %not a(iu) * 7225 FAULT 1 %REPEAT is not required * 7225 FAULT 1 %REPEAT is not required * Failed to analyse line 7225 %REPEATUNTILNOT A(IU) ! * Failed to analyse line 7225 %REPEATUNTILNOT A(IU) ! 7226 %unless a(keystart) %start * Failed to analyse line 7226 %UNLESS A(KEYSTART) %START ! * Failed to analyse line 7226 %UNLESS A(KEYSTART) %START ! 7227 get INSTRUCTION 7228 %else * 7228 FAULT 51 %FINISH is not required * 7228 FAULT 51 %FINISH is not required 7229 exit2: 7230 get(terminator) 7231 curlab = curlab+2 7232 get STATEMENTS(keyfinish) 7233 curlab = curlab-2 7234 -> initial(keyend) %if atom = keyend 7235 %finish 7236 -> term 7237 7238 initial(keycycle): 7239 this is inst 7240 %if a(terminator) %start * Failed to analyse line 7240 %IF A(TERMINATOR) %START ! * Failed to analyse line 7240 %IF A(TERMINATOR) %START ! 7241 define label(curlab) 7242 get LOOP BODY 7243 -> initial(keyend) %if atom = keyend 7244 get CONDITION %if a(keyuntil) * Failed to analyse line 7244 GETCONDITION %IF A(KEYUNTIL) ! * Failed to analyse line 7244 GETCONDITION %IF A(KEYUNTIL) ! 7245 putact(repeat,curlab,0) 7246 -> term 7247 %finish * 7247 FAULT 51 %FINISH is not required * 7247 FAULT 51 %FINISH is not required 7248 nonstandard(22) 7249 get FOR CLAUSE 7250 -> for1 7251 initial(keywhile): 7252 this is inst 7253 define label(curlab) 7254 get CONDITION 7255 get(keycycle) 7256 get(terminator) 7257 compile(np0) 7258 get LOOP BODY 7259 -> initial(keyend) %if atom = keyend 7260 nonstandard(6) %and get CONDITION %if a(keyuntil) * Failed to analyse line 7260 NONSTANDARD(6) %AND GETCONDITION %IF A(KEYUNTIL) ! * Failed to analyse line 7260 NONSTANDARD(6) %AND GETCONDITION %IF A(KEYUNTIL) ! 7261 putact(repeat,curlab,0) 7262 ->term 7263 initial(keyfor): 7264 this is inst 7265 get FOR CLAUSE 7266 get(keycycle) 7267 for1: 7268 get(terminator) 7269 compile(np0) 7270 %if forinf > 0 %start; !Literal for loop 7271 !%continue must come to end for increment 7272 loopstart = dict(curlab)_val; !save start position 7273 dict(curlab)_val = 0 7274 %finish 7275 get LOOP BODY 7276 -> initial(keyend) %if atom = keyend 7277 %if forinf > 0 %start; !literal FOR loop 7278 define label(curlab) 7279 dict(curlab)_val = loopstart; !restore 7280 putact(compare,forinf,litref(endval)) 7281 putact(beq,0,curlab) 7282 %finish 7283 putact(repeat,curlab,forinf) 7284 -> term 7285 7286 initial(keyon): 7287 fault(ordererr+point) %if c_status >= hadon %or stopper = 0 7288 do dynamic arrays %if c_dynarray # 0 7289 c_status = c_status!hadon 7290 matched = 1 7291 allow(keyevent) 7292 dump = 0 7293 %cycle 7294 get LITERAL(inttype) 7295 expfault(rangerr) %unless 0 <= value <= 15 7296 dump = dump!1< initial(keyend) %if atom = keyend 7304 -> term 7305 ! 7306 initial(keyelse): 7307 -> ignore %if starts # 0 7308 %return %if stopper = keyelse 7309 error(noif) %if stopper = keyfinish 7310 initial(keyfinish): 7311 starts = starts-1 %and -> ignore %if starts # 0 7312 %return %if stopper = keyfinish %or stopper = keyelse 7313 error(nostart) 7314 initial(keyrepeat): 7315 cycles = cycles-1 %and -> ignore %if cycles # 0 7316 %return %if stopper = keyrepeat 7317 error(nocycle) 7318 7319 initial(star): 7320 fault(lowlevel+warn+point) %and control = control!lowbit %if control&lowbit = 0 7321 matched = 1 7322 %if byteinteger(fp) = '=' %start 7323 fp = fp+1 7324 get LITERAL(inttype) 7325 plant(dc,0,temp(absmode,value)) 7326 %else 7327 get MCODE 7328 %finish 7329 ->term 7330 7331 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 7332 !!!!!!!!!!!!!!!!!!!! Declarations !!!!!!!!!!!!!!!!!!!!!!!!!!!! 7333 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 7334 ! 7335 %routine DECLARE LIT RANGE(%integer basetype,lo,hi) 7336 %own%record(objinfo) D=0 7337 fault(boundserr) %and hi = lo %if lo > hi 7338 item = ranges 7339 %cycle 7340 ditem == dict(item) 7341 item = item-2 %and %return %if ditem_val = hi %and ditem_type = basetype %c C %and dict(item-1)_val = lo 7343 item = ditem_hlink 7344 %repeat %until item = 0 7345 declare anon(d); !blank (for updating) 7346 declare range(basetype,lo,hi) 7347 %end 7348 7349 %routine DECLARE STRING TYPE(%integer size) 7350 item = stringtype %and %return %if size = -256 7351 item = string1 %and %return %if size = -2 7352 item = ranges 7353 %cycle 7354 ditem == dict(item) 7355 %return %if ditem_size = size %and ditem_type = chartype 7356 item = ditem_hlink 7357 %repeat %until item = 0 7358 declare anon(details(typeid+stringy,chartype,0,0)) 7359 ditem_size = size 7360 ditem_hlink = ranges; ranges = item 7361 %end 7362 7363 %routine GET LIT RANGE(%integer basetype) 7364 %integer holdval 7365 get LITERAL(basetype); holdval = value 7366 get(colon) 7367 get LITERAL(basetype) 7368 declare lit range(basetype,holdval,value) 7369 %end 7370 7371 %routine GET IDENTLIST(%record(objinfo)%name d) 7372 dlim0 = dlim 7373 get(ident) %and declare(d) %until %not a(comma) * Failed to analyse line 7373 GET(IDENT) %AND DECLARE(D) %UNTILNOT A(COMMA) ! * Failed to analyse line 7373 GET(IDENT) %AND DECLARE(D) %UNTILNOT A(COMMA) ! 7374 %end 7375 7376 %routine RECALIGN(%integername val) 7377 align(val,2) 7378 val = -val %if val > 4 7379 %end 7380 7381 %routine GET DECLARATION(%integer FLAGS,MODE,%integer%name DISP,%integer DEPTH) 7382 %record(objinfo) DECL 7383 %record(identinfo)%name DFHOLD 7384 %owninteger ITEMTYPE=0,ITEMSIZE=0,ADIM=0 7385 %integer BASE,HOLD,MAX,STMAX,DREG,AREG 7386 7387 %routine%spec GET VAR BOUND 7388 7389 %routine GET DATA TYPE 7390 %switch s(ktype:keyname) 7391 atom = next atom %if matched # 0 7392 syntax error %unless kattrib <= atom <= keyname 7393 matched = 1 7394 -> s(atom) 7395 s(ktype): 7396 itemtype = inttype+subatom 7397 itemsize = size(itemtype) 7398 nonstandard(7) %if itemtype >= mitetype 7399 allow(keyinteger) 7400 %return 7401 s(keyinteger): !%integer 7402 itemtype = inttype; itemsize = 4 7403 %if a(left) %start * Failed to analyse line 7403 %IF A(LEFT) %START ! * Failed to analyse line 7403 %IF A(LEFT) %START ! 7404 nonstandard(8) 7405 get LIT RANGE(inttype) 7406 get(right) 7407 itemtype = item 7408 itemsize = typecell(itemtype)_size 7409 %finish * 7409 FAULT 51 %FINISH is not required * 7409 FAULT 51 %FINISH is not required 7410 %return 7411 s(keylong): !%long 7412 itemtype = inttype; itemsize = 4; !**for now** 7413 %if a(keyinteger) %then fault(notin+point+warn) %c C %else itemtype = realtype %and get(keyreal) * Failed to analyse line 7414 %IF A(KEYINTEGER) %THEN FAULT(NOTIN+POINT+WARN) %ELSE ITEMTYPE=REALTYPE %AND GET(KEYREAL) ! * Failed to analyse line 7414 %IF A(KEYINTEGER) %THEN FAULT(NOTIN+POINT+WARN) %ELSE ITEMTYPE=REALTYPE %AND GET(KEYREAL) ! 7415 %return 7416 s(keyreal): !%real 7417 itemtype = realtype; itemsize = 4 7418 %return 7419 s(keystring): !%string 7420 itemsize = 0 7421 %if a(left) %start * Failed to analyse line 7421 %IF A(LEFT) %START ! * Failed to analyse line 7421 %IF A(LEFT) %START ! 7422 atom = next atom 7423 ! %if depth # 0 %and ktype <= atom <= keyinteger %start 7424 ! get VAR BOUND 7425 ! itemtype = stringstar 7426 ! %else %if a(star) 7427 %if a(star) %start * Failed to analyse line 7427 %IF A(STAR) %START ! * Failed to analyse line 7427 %IF A(STAR) %START ! 7428 itemtype = stringstar 7429 %else * 7429 FAULT 51 %FINISH is not required * 7429 FAULT 51 %FINISH is not required 7430 get LITERAL(bytetype) 7431 itemsize = -(value+1) 7432 declare string type(itemsize) 7433 itemtype = item 7434 %finish 7435 get(right) 7436 %else * 7436 FAULT 51 %FINISH is not required * 7436 FAULT 51 %FINISH is not required 7437 syntax error %if mode # constmode 7438 itemtype = stringtype 7439 %finish 7440 %return 7441 s(keyrecord): !%record 7442 get(left) 7443 %unless a(star) %start * Failed to analyse line 7443 %UNLESS A(STAR) %START ! * Failed to analyse line 7443 %UNLESS A(STAR) %START ! 7444 %unless a(ident) %start * Failed to analyse line 7444 %UNLESS A(IDENT) %START ! * Failed to analyse line 7444 %UNLESS A(IDENT) %START ! 7445 declare anon(typeident) 7446 hold = item; dfhold == dformat 7447 dformat == ditem 7448 get DECLARATION(writable+readable,0,dformat_val,0) 7449 recalign(dformat_val) 7450 ditem == dformat 7451 dformat == dfhold; item = hold 7452 %finish * 7452 FAULT 51 %FINISH is not required * 7452 FAULT 51 %FINISH is not required 7453 name error %if item <= 0 7454 error(classerr+point) %if ditem_flags&(\spec) # typeid+recy 7455 itemtype = item; itemsize = ditem_val 7456 %else * 7456 FAULT 51 %FINISH is not required * 7456 FAULT 51 %FINISH is not required 7457 itemtype = recstar; itemsize = 0 7458 %finish 7459 get(right) 7460 %return 7461 s(keyname): !untyped %name - leave unmatched 7462 itemtype = 0; matched = 0 7463 %end 7464 7465 %routine ASSIGN ADDRESS(%integer size) 7466 7467 %routine ASSIGN STACK ADDRESS 7468 align(stmax,2); ditem_val = stmax 7469 stmax = stmax+imod(size) 7470 c_status = c_status!onstack %if depth = 1 %and speccing = 0 7471 %end 7472 7473 size = -4 %if ditem_flags&(name+indirect) # 0 7474 %if depth # 0 %start 7475 dlink_link = item; dlink == ditem 7476 %if size > 0 %start 7477 !simple value 7478 %if dreg > maxcalldreg %start 7479 assign stack address 7480 %return 7481 %finish 7482 c_reg_content(dreg) = item %if speccing = 0 7483 ditem_reg = dreg-d0; dreg = dreg+1 7484 %else 7485 %if areg > maxcallareg %start 7486 assign stack address 7487 ditem_reg = 8 {would have been in AREG} 7488 %return 7489 %finish 7490 c_reg_content(areg) = item+ad %if speccing = 0 %and ditem_flags < 0 7491 ditem_reg = areg-d0; areg = areg+1 7492 %finish 7493 %finish 7494 size = imod(size) 7495 align(disp,size) 7496 ditem_val = disp 7497 %if constmode # ditem_mode # ownmode %start 7498 disp = disp+size 7499 %if ditem_mode >= framemode %start 7500 align(disp,2) 7501 ditem_val = c_sp-disp; !neg stack disp. 7502 %finish 7503 %finish 7504 %end 7505 ! 7506 %routine GET QIDENT 7507 get(ident) 7508 %if mode = 0 %start; !within record format 7509 head == dformat_link; item = head 7510 %if item > 0 %start 7511 %cycle 7512 ditem == dict(item) 7513 fault(duperr+point) %if string(ditem_text+char0) = string(charlim) 7514 head == ditem_hlink; item = head 7515 %repeat %until item <= 0 7516 %finish 7517 %finish 7518 declare(decl) 7519 %end 7520 7521 !< 1 7536 %if mode = constmode %start 7537 i = cad; cad = cad+kk 7538 croak("Program too big") %if cad >= ownbase 7539 %else 7540 %if ownbase+ownad+kk-finalbound > 0 %start 7541 make room(ownbase+ownad+kk-finalbound) 7542 %finish 7543 i = ownbase+ownad; ownad = ownad+kk 7544 %finish 7545 %if itemsize <= 0 %start 7546 %while n > 0 %cycle 7547 n = n-1; j = i+k 7548 %if v # 0 %start 7549 vv = v 7550 %cycle 7551 final(i) = final(vv) 7552 i = i+1; vv = vv+1 7553 %repeat %until i =j 7554 %else 7555 final(i) = 0 %and i = i+1 %while i < j 7556 %finish 7557 %repeat 7558 %else 7559 !$IF VAX 7560 { v = ieee(v) %if itemtype = realtype; !vax->ieee 7561 !$FINISH 7562 %while n > 0 %cycle 7563 n = n-1 7564 %if itemsize >= 2 %start 7565 %if itemsize > 2 %start; !longword 7566 final(i) <- v>>24 7567 final(i+1) <- v>>16 7568 i = i+2 7569 %finish 7570 final(i) <- v>>8 7571 i = i+1 7572 %finish 7573 final(i) <- v 7574 i = i+1 7575 %repeat 7576 %finish 7577 %end; !dump const 7578 !<= framemode %start 7593 ditem_flags = ditem_flags!mflag 7594 assign address(4) 7595 %finish 7596 %end 7597 7598 %routine GET ARRAY DECLARATION(%integer dim) 7599 %integer pos,dlim1,holdval,holdz,jam,elements,tot,totsize,lo1,size1 7600 %record(identinfo)%name dp 7601 %ownrecord(objinfo) ATYPE=0 7602 7603 %integer%fn XTYPE 7604 declare anon(details(typeid,inttype,0,0)) 7605 %result = item 7606 %end 7607 7608 %routine STRING STAR ARRAY 7609 fault(notin+point) %if depth = 0 7610 ! VAR for size 7611 declare anon(details(okflag+mflag+inty,inttype,mode,0)) 7612 tot = item 7613 assign address(4) 7614 ! TYPEID for string(*) 7615 declare anon(details(typeid+stringy,inttype,0,0)) 7616 atype_type = item 7617 elements = maxint 7618 %end 7619 7620 %routine GET REST 7621 %integer e,r,lo,loval,hi,hival 7622 r = 0 7623 atom = next atom %if matched # 0 7624 %if decl_flags < 0 %start; !%array%name 7625 %if depth > 0 %and ktype <= atom <= keyinteger %start; !variable 7626 r = xtype; get VAR BOUND 7627 %else 7628 get LITERAL(inttype) 7629 %finish 7630 %else; !%array 7631 get VALUE(inttype) 7632 %finish 7633 loval = value; lo = item 7634 loval = minint %if lo # 0 7635 get(colon) 7636 atom = next atom %if matched # 0 7637 %if decl_flags < 0 %start 7638 %if depth > 0 %and ktype <= atom <= keyinteger %start; !variable 7639 %if r = 0 %start 7640 r = xtype; declare bound(litmode,loval) 7641 %finish 7642 get VAR BOUND 7643 %else 7644 %if dim!r = 0 %and a(star) %start * Failed to analyse line 7644 %IF DIM!R=0 %AND A(STAR) %START ! * Failed to analyse line 7644 %IF DIM!R=0 %AND A(STAR) %START ! 7645 item = 0; value = maxint 7646 %else 7647 get LITERAL(inttype) 7648 declare bound(litmode,value) %if r # 0 7649 %finish 7650 %finish 7651 %else * 7651 FAULT 51 %FINISH is not required * 7651 FAULT 51 %FINISH is not required 7652 get VALUE(inttype) 7653 %finish 7654 hival = value; hi = item 7655 hival = maxint %if hi # 0 7656 e = maxint 7657 %if r = 0 %start; !no range yet declared 7658 %if lo!hi = 0 %start 7659 e = hival-loval %if hival!!loval >= 0 %or minint+hival-loval < 0 7660 e = e+1 %if e # maxint 7661 e = 0 %if hival = maxint 7662 declare lit range(inttype,loval,hival) 7663 %else 7664 declare anon(typeident); !blank (for updating) 7665 declare range(inttype,loval,hival) 7666 %finish 7667 r = item 7668 %finish 7669 elements = e 7670 %if a(comma) %start * Failed to analyse line 7670 %IF A(COMMA) %START ! * Failed to analyse line 7670 %IF A(COMMA) %START ! 7671 dim = dim+1 7672 get REST 7673 %if elements # maxint %and e # maxint %start 7674 elements = elements*e 7675 %else 7676 elements = maxint 7677 %finish 7678 %finish * 7678 FAULT 51 %FINISH is not required * 7678 FAULT 51 %FINISH is not required 7679 atype_xtype = r 7680 size1 = totsize; lo1 = loval; !for outer dimension 7681 string star array %if atype_type = stringstar 7682 %if elements = maxint %start; !non-literal bounds 7683 atype_mode = mode 7684 declare anon(atype) 7685 atype_type = item; !save type id 7686 %if decl_flags >= 0 %or (depth = 1 %and speccing = 0) %start 7687 lo = litref(loval) %if lo = 0 7688 hi = litref(hival) %if hi = 0 7689 tot = litref(totsize) %if tot = 0 7690 putact(asize,item,tot) 7691 putact(0,lo,hi) 7692 %if decl_flags >= 0 %start 7693 compile(np0) 7694 dict(r+1)_mode = c_mode %and dict(r+1)_val = c_sp+4 %if lo > 0 7695 dict(r+2)_mode = c_mode %and dict(r+2)_val = c_sp %if hi > 0 7696 %finish 7697 %finish 7698 tot = 0; totsize = 0 7699 %else; !literal bounds 7700 item = 0 7701 %cycle 7702 ditem == dict(item) 7703 %exit %if ditem_type = atype_type %and ditem_xtype = atype_xtype %c C %and ditem_flags = atype_flags 7705 item = item+1 7706 %if item = dlim %start 7707 declare anon(atype) 7708 %exit 7709 %finish 7710 %repeat 7711 atype_type = item 7712 totsize = totsize*e 7713 %finish 7714 %end; !get REST 7715 7716 %routine PUT BOUNDS 7717 %integer i 7718 i = xtype; !index type 7719 declare bound(mode,0); !lower 7720 declare bound(mode,0); !upper 7721 dim = dim-1 7722 put bounds %if dim > 0 7723 string star array %if atype_type = stringstar 7724 atype_xtype = i 7725 declare anon(atype); !array type 7726 %if speccing = 0 %start 7727 tot = litref(totsize) %if tot = 0 7728 putact(asize,item,tot) 7729 putact(0,i+1,i+2) 7730 %finish 7731 tot = 0; totsize = 0; lo1 = minint 7732 atype_type = item 7733 %end 7734 7735 pos = dlim0; dlim1 = dlim; dp == ditem 7736 atype_flags = typeid+arry+okflag; atype_type = itemtype 7737 %if atype_type < 0 %start; !element %name 7738 atype_flags = atype_flags+name; atype_type = atype_type-name 7739 %finish 7740 atype_mode = constmode; !by default (literal bounds) 7741 tot = 0; totsize = imod(itemsize) 7742 %if dim > 0 %start; !%array(n)%name 7743 atype_mode = mode 7744 put bounds 7745 elements = maxint 7746 %else; !left parenthesis recognised 7747 get REST 7748 get(right) 7749 %finish 7750 dp_type = atype_type 7751 %if mode # constmode %and mode # ownmode %start 7752 holdval = d0 7753 %while pos # dlim1 %cycle 7754 dp == dict(pos) 7755 dp_type = atype_type 7756 %if mode >= framemode %start 7757 dp_flags = dp_flags!arrflag %if lo1 = minint %or size1 = 0 7758 %if decl_flags >= 0 %start; !%array not %array%name 7759 %if totsize # 0 {all literal bounds} %c C %and totsize<<1-c_sp+disp <= 32000 %start 7761 !if array will occupy less than half remaining reach 7762 !then allocate directly on stack 7763 disp = disp+totsize 7764 align(disp,2) 7765 %else 7766 fault(ordererr) %if c_mode&2_01000000 # 0; !hard order error 7767 %if totsize # 0 %start; !known bounds but too big 7768 c_extra = c_extra+totsize 7769 holdval = litref(totsize) 7770 %finish 7771 ![ADOK updates C_SP] 7772 holdz = 0; holdz = litref(-lo1*size1) %if dp_flags&arrflag = 0 7773 putact(adok,holdval,holdz); !compute & store space needed 7774 compile(np0) 7775 dp_flags = dp_flags+indirect 7776 dp_link = c_dynarray 7777 c_dynarray = pos; c_dynarray = -c_dynarray %if holdz # 0 7778 c_status = c_status!unknown 7779 holdval = 0 7780 %finish 7781 dp_val = c_sp-disp 7782 %finish 7783 %else { %if decl_flags >= 0}; !record field or absolute 7784 !** to be corrected ** 7785 !name already allocated 7786 { dp_val = disp; disp = disp+totsize} 7787 dp_val = disp 7788 %if decl_flags < 0 %then disp = disp+4 %else disp = disp+totsize 7789 %finish 7790 pos = pos+1 7791 %repeat 7792 %else; !const,own 7793 %if decl_flags&(name+indirect) # 0 %start 7794 %if mode = constmode %then fill code(4) %else fill own(4) 7795 %else 7796 %if a assop(itemtype) %start * Failed to analyse line 7796 %IF AASSOP(ITEMTYPE) %START ! * Failed to analyse line 7796 %IF AASSOP(ITEMTYPE) %START ! 7797 jam = jammy 7798 dp_flags = dp_flags!okflag; ![hum] 7799 allow(terminator) 7800 %cycle 7801 jammy = jam 7802 get VALUE(itemtype) 7803 faultnum = rangerr+point+warn %if faultnum = rangerr+point 7804 holdval = value 7805 value = 1 7806 %if a(left) %start * Failed to analyse line 7806 %IF A(LEFT) %START ! * Failed to analyse line 7806 %IF A(LEFT) %START ! 7807 value = elements 7808 get LITERAL(halftype) %unless a(star) * Failed to analyse line 7808 GETLITERAL(HALFTYPE) %UNLESS A(STAR) ! * Failed to analyse line 7808 GETLITERAL(HALFTYPE) %UNLESS A(STAR) ! 7809 get(right) 7810 %finish * 7810 FAULT 59 %FINISH instead of %REPEAT for %CYCLE at line 7800 * 7810 FAULT 59 %FINISH instead of %REPEAT for %CYCLE at line 7800 7811 elements = elements-value 7812 value = value+elements %if elements < 0 7813 dump const(holdval,value) 7814 %repeat %until %not a(comma) * 7814 FAULT 52 %REPEAT instead of %FINISH for %START at line 7795 * 7814 FAULT 52 %REPEAT instead of %FINISH for %START at line 7795 * Failed to analyse line 7814 %REPEATUNTILNOT A(COMMA) ! * Failed to analyse line 7814 %REPEATUNTILNOT A(COMMA) ! 7815 %if faultnum = 0 %and elements # 0 %start 7816 %if elements < 0 %then report(counterr,pos,elements) %c C %else report(counterr+warn,pos,elements) 7818 %finish 7819 %finish 7820 dump const(0,elements) %if elements > 0 7821 %finish * 7821 FAULT 51 %FINISH is not required * 7821 FAULT 51 %FINISH is not required 7822 %finish * 7822 FAULT 51 %FINISH is not required * 7822 FAULT 51 %FINISH is not required 7823 %end; !get ARRAY DECLARATION 7824 ! 7825 %routine GET PROCEDURE DECLARATION 7826 %integer pos,dlim1,argmode,argad,restype,stack 7827 %record(identinfo)%name headditem,dhold 7828 7829 %integerfn DUPOK 7830 !Check that the proc being declared can reasonably alias existing id 7831 %record(identinfo)%name tp 7832 %result = FALSE %if ditem_flags&proc = 0 7833 tp == typecell(ditem_type) 7834 %if restype = 0 %start; !routine 7835 %result = FALSE %if tp_type # 0 %or tp_link = 0; !not routine, or no pars 7836 %else 7837 %result = FALSE %if restype = tp_type; !function of same type 7838 %finish 7839 %result = TRUE 7840 %end 7841 7842 restype = itemtype 7843 stack = 0; !unknown 7844 decl_flags = decl_flags&(\okflag) 7845 decl_type = procstar; !by default 7846 %if depth # 0 %start; !procedure as param 7847 decl_flags = decl_flags!proc2; ![must push MB in case external] 7848 %else %if mode >= framemode * Failed to analyse line 7848 %ELSEIF MODE>=FRAMEMODE ! * Failed to analyse line 7848 %ELSEIF MODE>=FRAMEMODE ! 7849 decl_mode = procmode; decl_val = 0 7850 decl_flags = decl_flags!proc1 7851 decl_flags = decl_flags!spec %if a(keyspec) * Failed to analyse line 7851 DECL_FLAGS=DECL_FLAGS!SPEC %IF A(KEYSPEC) ! * Failed to analyse line 7851 DECL_FLAGS=DECL_FLAGS!SPEC %IF A(KEYSPEC) ! 7852 %else %if mode = ownmode; !external (not @) * Failed to analyse line 7852 %ELSEIF MODE=OWNMODE; ! * Failed to analyse line 7852 %ELSEIF MODE=OWNMODE; ! 7853 decl_mode = procmode; decl_val = 0 7854 %if a(keyspec) %start * Failed to analyse line 7854 %IF A(KEYSPEC) %START ! * Failed to analyse line 7854 %IF A(KEYSPEC) %START ! 7855 decl_mode = ownmode; decl_flags = decl_flags!spec 7856 %finish 7857 %else; !@... * 7857 FAULT 51 %FINISH is not required * 7857 FAULT 51 %FINISH is not required 7858 decl_flags = decl_flags!proc1 7859 decl_val = disp 7860 stack = 4 7861 %finish 7862 %if decl_flags&ext # 0 %and a(keyalias) %start * Failed to analyse line 7862 %IF DECL_FLAGS&EXT#0 %AND A(KEYALIAS) %START ! * Failed to analyse line 7862 %IF DECL_FLAGS&EXT#0 %AND A(KEYALIAS) %START ! 7863 nonstandard(9) 7864 get(ident) 7865 %if item <= 0 %start 7866 fault(namerr+point) 7867 %else 7868 item = 0 %and decl_flags = decl_flags!alt %if dupok * Failed to analyse line 7868 ITEM=0 %AND DECL_FLAGS=DECL_FLAGS!ALT %IF DUPOK ! * Failed to analyse line 7868 ITEM=0 %AND DECL_FLAGS=DECL_FLAGS!ALT %IF DUPOK ! 7869 %finish 7870 %else * 7870 FAULT 51 %FINISH is not required * 7870 FAULT 51 %FINISH is not required 7871 get(ident) 7872 %finish 7873 declare(decl) 7874 headditem == ditem 7875 assign address(-6) %if depth # 0 7876 argmode = c_mode&(\2_01000000)+1 7877 %if decl_flags&spec # 0 %or decl_mode # procmode %start 7878 speccing = speccing+1 7879 %else 7880 c_forward = c_forward-1 %if ditem_flags&rflag # 0 7881 open block(item) 7882 c_type = restype 7883 c_type = c_type!sign16 %if decl_flags&writable # 0 {%map} 7884 %finish 7885 dlim1 = dlim 7886 declare anon(details(0,restype,0,stack)) 7887 ! Result in A0 for %map or structure %fn 7888 ditem_reg = 8 %if decl_flags&writable # 0 {%map} %C C %or size(restype) <= 0 {structure %fn} 7890 !Declare parameters 7891 argad = c_sp; !ok for both spec and body 7892 %if a(left) %start * Failed to analyse line 7892 %IF A(LEFT) %START ! * Failed to analyse line 7892 %IF A(LEFT) %START ! 7893 dhold == dlink; dlink == ditem 7894 get DECLARATION(okflag+writable+readable,argmode,argad,1) 7895 dlink == dhold 7896 get(right) 7897 %finish * 7897 FAULT 51 %FINISH is not required * 7897 FAULT 51 %FINISH is not required 7898 %if speccing # 0 %start 7899 speccing = speccing-1 7900 pos = crunched(dlim1) 7901 %if pos < dlim1 %or speccing = 0 %start 7902 headditem_type = pos 7903 %else; !proc as param 7904 fault(classerr); dlim = dlim1 7905 %finish 7906 %else; !procedure body 7907 %if c_dpid_flags&spec # 0 %start 7908 c_dpid_flags = c_dpid_flags-spec 7909 %unless parmatch(c_dpid_type,dlim1) %start * Failed to analyse line 7909 %UNLESS PARMATCH(C_DPID_TYPE,DLIM1) %START ! * Failed to analyse line 7909 %UNLESS PARMATCH(C_DPID_TYPE,DLIM1) %START ! 7910 %if c_pid = dlim1-2 %then fault(matcherr+warn) %c C %else fault(matcherr) 7912 %finish 7913 %finish 7914 headditem_type = dlim1 7915 c_parlim = dlim 7916 c_sp = -argad 7917 compile(np0) 7918 get(terminator) 7919 get STATEMENTS(keyend) 7920 %finish * 7920 FAULT 51 %FINISH is not required * 7920 FAULT 51 %FINISH is not required 7921 %end; !get procedure declaration 7922 7923 %routine GET INITIAL VALUE(%record(identinfo)%name dp) 7924 %integer present=0 * Failed to analyse line 7924 %INTEGER PRESENT=0 ! * Failed to analyse line 7924 %INTEGER PRESENT=0 ! 7925 jammy = 0 7926 %if a assop(itemtype) %start * Failed to analyse line 7926 %IF AASSOP(ITEMTYPE) %START ! * Failed to analyse line 7926 %IF AASSOP(ITEMTYPE) %START ! 7927 get VALUE(itemtype) 7928 dp_flags = dp_flags!okflag 7929 present = 1 7930 %finish * 7930 FAULT 51 %FINISH is not required * 7930 FAULT 51 %FINISH is not required 7931 %if mode >= framemode %start; !dynamic 7932 %if present # 0 %start 7933 atomp = expp %and nonstandard(1) %if item # 0 7934 %if itemtype < 0 %start 7935 putact(okass,dlim0+ad,normitem) 7936 %else 7937 putact(okass+jammy,dlim0,normitem) 7938 %finish 7939 compile(np0) 7940 %finish 7941 %else %if mode = constmode * Failed to analyse line 7941 %ELSEIF MODE=CONSTMODE ! * Failed to analyse line 7941 %ELSEIF MODE=CONSTMODE ! 7942 syntax error %if present = 0 7943 %if itemtype < 0 %start; !name 7944 dp_flags = writable+readable 7945 dp_mode = absmode; dp_val = value 7946 %else 7947 faultnum = rangerr+point+warn %if faultnum = rangerr+point 7948 %if itemsize <= 0 %then dump const(value,1) %c C %else dp_mode = litmode %and dp_val = value 7950 %finish 7951 %else; !own 7952 %if present # 0 %start 7953 faultnum = rangerr+point+warn %if faultnum = rangerr+point 7954 dump const(value,1) 7955 %else 7956 %if itemtype < 0 %then fill own(4) %else fill own(imod(itemsize)) 7957 %finish 7958 %finish 7959 %end; !get initial value 7960 7961 dreg = d0; areg = a0; stmax = 8; !allow for RETAD & LINK 7962 max = 0; base = disp 7963 %cycle 7964 disp = base 7965 %cycle 7966 decl = 0 7967 decl_flags = flags; decl_mode = mode 7968 adim = -1 7969 %while a(kattrib) %cycle * Failed to analyse line 7969 %WHILE A(KATTRIB) %CYCLE ! * Failed to analyse line 7969 %WHILE A(KATTRIB) %CYCLE ! 7970 decl_flags = decl_flags!!(1<= 0 %and disp ## jokerad %c C %and decl_type # stringtype {const} 8029 %if disp == c_val %start; !main declaration 8030 fault(notinblock) %if stopper = 0 8031 %if c_status >= hadon %start 8032 %if c_forward!c_return # 0 %or curlab # c_lab1 %start 8033 fault(ordererr) 8034 %else %if c_status&hadordererr = 0 * Failed to analyse line 8034 %ELSEIF C_STATUS&HADORDERERR=0 ! * Failed to analyse line 8034 %ELSEIF C_STATUS&HADORDERERR=0 ! 8035 fault(ordererr+warn); c_status = c_status+hadordererr 8036 %finish 8037 %finish 8038 %else %if decl_flags&ext # 0 %and a(keyspec) * Failed to analyse line 8038 %ELSEIF DECL_FLAGS&EXT#0 %AND A(KEYSPEC) ! * Failed to analyse line 8038 %ELSEIF DECL_FLAGS&EXT#0 %AND A(KEYSPEC) ! 8039 decl_flags = decl_flags!(spec+indirect) 8040 %finish 8041 !Read identifier list 8042 %cycle 8043 dlim0 = dlim 8044 %unless decl_type = arrstar %start; !not array 8045 get QIDENT 8046 assign address(itemsize) 8047 %if mode >= ownmode %and depth = 0 %start 8048 %if decl_flags&spec = 0 %then get INITIAL VALUE(ditem) %c C %else set own word(0) %and set own word(0) 8050 %finish 8051 %else 8052 %cycle 8053 get QIDENT 8054 assign address(0); !(4 if name) 8055 %exit %unless a(comma) * Failed to analyse line 8055 %EXITUNLESS A(COMMA) ! * Failed to analyse line 8055 %EXITUNLESS A(COMMA) ! 8056 atom = next atom 8057 %if atom # ident %start; !ie new type 8058 %if adim = 0 %start; !treat %array%name as %array(1)%name 8059 syntax error %if decl_flags >= 0 8060 adim = 1 8061 %finish 8062 get ARRAY DECLARATION(adim) 8063 -> exit22 8064 %finish 8065 %repeat 8066 %if adim # 0 %or %not a(left) %start * Failed to analyse line 8066 %IF ADIM#0 %ORNOT A(LEFT) %START ! * Failed to analyse line 8066 %IF ADIM#0 %ORNOT A(LEFT) %START ! 8067 %if adim = 0 %start 8068 syntax error %if decl_flags >= 0 8069 adim = 1 8070 %finish 8071 get ARRAY DECLARATION(adim) 8072 -> exit2 8073 %finish 8074 get ARRAY DECLARATION(adim) 8075 %finish * 8075 FAULT 59 %FINISH instead of %REPEAT for %CYCLE at line 8042 * 8075 FAULT 59 %FINISH instead of %REPEAT for %CYCLE at line 8042 8076 -> exit2 %unless a(comma) * Failed to analyse line 8076 ->EXIT2 %UNLESS A(COMMA) ! * Failed to analyse line 8076 ->EXIT2 %UNLESS A(COMMA) ! 8077 atom = next atom 8078 %repeat %until atom # ident * 8078 FAULT 1 %REPEAT is not required * 8078 FAULT 1 %REPEAT is not required 8079 exit22: 8080 %continue 8081 %finish * 8081 FAULT 51 %FINISH is not required * 8081 FAULT 51 %FINISH is not required 8082 %finish * 8082 FAULT 51 %FINISH is not required * 8082 FAULT 51 %FINISH is not required 8083 %exit %unless a(comma); ![NB %continue above] * Failed to analyse line 8083 %EXITUNLESS A(COMMA); ! * Failed to analyse line 8083 %EXITUNLESS A(COMMA); ! 8084 %repeat * 8084 FAULT 1 %REPEAT is not required * 8084 FAULT 1 %REPEAT is not required 8085 exit2: 8086 max = disp %if disp > max 8087 %repeat %until %not a(keyor) * 8087 FAULT 1 %REPEAT is not required * 8087 FAULT 1 %REPEAT is not required * Failed to analyse line 8087 %REPEATUNTILNOT A(KEYOR) ! * Failed to analyse line 8087 %REPEATUNTILNOT A(KEYOR) ! 8088 disp = max 8089 %end; !get declaration 8090 8091 initial(keyconst): 8092 literal = 1 8093 get DECLARATION(okflag+readable,constmode,cad,0) 8094 -> term 8095 8096 initial(atsign): 8097 dump = 0 8098 atted: 8099 fault(lowlevel+warn+point) %and control = control!lowbit %if control&lowbit = 0 8100 get LITERAL(inttype) 8101 jokerad = value 8102 %if a(left) %start * Failed to analyse line 8102 %IF A(LEFT) %START ! * Failed to analyse line 8102 %IF A(LEFT) %START ! 8103 get MIDENT(a0,a7) 8104 get(right) 8105 value = item+(dispmode-a0) 8106 %finish %else value = absmode * 8106 FAULT 51 %FINISH is not required * 8106 FAULT 51 %FINISH is not required 8107 literal = 1 8108 get DECLARATION(dump!(okflag+writable+readable),value,jokerad,0) 8109 -> term 8110 8111 initial(keyown): 8112 literal = 1 8113 get DECLARATION(writable+readable,ownmode,ownad,0) 8114 -> term 8115 8116 initial(keyext): 8117 fault(ordererr) %if level # outerlevel 8118 literal = 1 8119 dump = subatom<<12 8120 -> atted %if a(atsign) * Failed to analyse line 8120 ->ATTED %IF A(ATSIGN) ! * Failed to analyse line 8120 ->ATTED %IF A(ATSIGN) ! 8121 %if a(left) %start * Failed to analyse line 8121 %IF A(LEFT) %START ! * Failed to analyse line 8121 %IF A(LEFT) %START ! 8122 get LITERAL(inttype); get(right) 8123 maxcalldreg = (d0-1)+value&15 8124 maxcallareg = (a0-1)+value>>4&15 8125 dump = dump!!(value&(\255)) 8126 %finish * 8126 FAULT 51 %FINISH is not required * 8126 FAULT 51 %FINISH is not required 8127 get DECLARATION(dump!(writable+readable),ownmode,ownad,0) 8128 -> term 8129 8130 initial(keyrecord): 8131 %unless a(left) %start * Failed to analyse line 8131 %UNLESS A(LEFT) %START ! * Failed to analyse line 8131 %UNLESS A(LEFT) %START ! 8132 get(keyformat) 8133 %if a(keyspec) %start * Failed to analyse line 8133 %IF A(KEYSPEC) %START ! * Failed to analyse line 8133 %IF A(KEYSPEC) %START ! 8134 typeident_flags = typeid+spec+recy 8135 get(ident); declare(typeident) 8136 %else * 8136 FAULT 51 %FINISH is not required * 8136 FAULT 51 %FINISH is not required 8137 typeident_flags = typeid+recy 8138 get(ident); declare(typeident) 8139 get(left) 8140 dformat == ditem 8141 get DECLARATION(writable+readable,0,dformat_val,0) 8142 recalign(dformat_val) 8143 get(right) 8144 %finish 8145 -> term 8146 %finish * 8146 FAULT 51 %FINISH is not required * 8146 FAULT 51 %FINISH is not required 8147 fp = fp-1; atom = keyrecord; !back-up 8148 initial(ktype): initial(keylong): 8149 initial(keyinteger): initial(keyreal): 8150 initial(kattrib): initial(keystring): 8151 initial(rpred): 8152 matched = 0 8153 get DECLARATION(writable+readable,c_mode,c_val,0) 8154 -> term 8155 8156 initial(keylabel): 8157 get IDENTLIST(forwardlabel) 8158 -> term 8159 8160 %routine GET SWITCH DECLARATION 8161 %integer i,lo,hi,dlim1 8162 %ownrecord(objinfo) d=0 8163 matched = 1 8164 %cycle 8165 d_type = arrstar; !(in case of error) 8166 d_flags = d_flags+arrflag %if control&arrbit # 0 8167 d_mode = labmode 8168 get IDENTLIST(d) 8169 dlim1 = dlim 8170 declare anon(details(typeid+arry,0,0,0)) 8171 get(left); get LIT RANGE(inttype); get(right) 8172 dict(dlim1)_xtype = item 8173 get bounds(item,lo,hi) 8174 %cycle; !For each ident in group 8175 %for i = lo,1,hi %cycle 8176 swpc = swpc-1; prog(swpc) = 0 8177 croak("Code space exhausted") %if swpc <= pc 8178 %repeat 8179 dict(dlim0)_val = swpc 8180 dict(dlim0)_type = dlim1 8181 dlim0 = dlim0+1 8182 %repeat %until dlim0 = dlim1 8183 %repeat %until %not a(comma) * Failed to analyse line 8183 %REPEATUNTILNOT A(COMMA) ! * Failed to analyse line 8183 %REPEATUNTILNOT A(COMMA) ! 8184 %end 8185 initial(keyswitch): 8186 literal = 1 8187 get SWITCH DECLARATION 8188 c_status = c_status!hadswitch 8189 ->term 8190 8191 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 8192 !!!!!!!!!!!!!!! Control statements !!!!!!!!!!!!!!!!!!!!!!!!!!! 8193 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 8194 ! 8195 %routine OPT 8196 %integer c=control * Failed to analyse line 8196 %INTEGER C=CONTROL ! * Failed to analyse line 8196 %INTEGER C=CONTROL ! 8197 set options(string(final0+value)) 8198 select output(listout); !**for now - PAM may alter** 8199 control = control&(\list) %if initcon&list = 0 8200 control = control!list %if control&(\c)&(ttlist+codelist+explist+dictlist) # 0 8201 %end 8202 8203 initial(keyoption): 8204 get LITSTRING 8205 get(terminator) 8206 opt %if faultnum = 0 8207 -> next 8208 8209 initial(keyinclude): 8210 get LITSTRING 8211 get(terminator) 8212 %if faultnum = 0 %start 8213 croak("Too many nested includes") %if curfile = 3 8214 line = line+1 %if sym = nl 8215 cur_fp = fp; cur_line = line 8216 fcontrol(curfile) = control 8217 control = control&(\list) %if control&(codelist+explist+dictlist) = 0 8218 curfile = curfile+1 8219 lastfile = -1 %if curfile = lastfile 8220 cur == file(curfile); cur = 0 8221 time1 = time1-cputime 8222 !! define param("INC",cur_name,nodefault) 8223 opt 8224 !! connect edfile(cur) 8225 time1 = time1+cputime 8226 %signal abandon %if cur_flag # 0 8227 line = 0; sym = nl 8228 curstart = cur_start2; curlim = cur_lim2 8229 fp = cur_start2 8230 %finish 8231 ->next 8232 8233 initial(keycontrol): 8234 get LITERAL(inttype) 8235 control = 0 %if value = 0 8236 control = control!!value 8237 show dict(0) %if control&dictlist # 0 8238 ->term 8239 8240 initial(keylist): 8241 control = control!list 8242 ->term 8243 8244 initial(keybegin): 8245 get(terminator) 8246 %if stopper = 0 %start; !first %begin 8247 c_localdpos = dlim; c_parlim = dlim 8248 c_access = 1 8249 get STATEMENTS(keyend) 8250 %return 8251 %finish 8252 declare anon(beginblock) 8253 open block(dlim0) 8254 get STATEMENTS(keyend) 8255 update sp 8256 this is inst 8257 srcall(dlim-1) 8258 -> term 8259 8260 initial(keyend): 8261 %if stopper > keyend %start 8262 %if stopper = keyrepeat %then fault(norepeat+now) %C C %else fault(nofinish+now) 8264 %else 8265 %if a(keyof) %start * Failed to analyse line 8265 %IF A(KEYOF) %START ! * Failed to analyse line 8265 %IF A(KEYOF) %START ! 8266 %if a(keylist) %start * Failed to analyse line 8266 %IF A(KEYLIST) %START ! * Failed to analyse line 8266 %IF A(KEYLIST) %START ! 8267 control = control&(\list) 8268 ->term 8269 %finish 8270 %if a(keyfile) %start * Failed to analyse line 8270 %IF A(KEYFILE) %START ! * Failed to analyse line 8270 %IF A(KEYFILE) %START ! 8271 fp = curlim; sym = nl 8272 ->next 8273 %finish * 8273 FAULT 51 %FINISH is not required * 8273 FAULT 51 %FINISH is not required 8274 get(keyprogram) 8275 fault(noend+now) %if level # outerlevel 8276 %finish * 8276 FAULT 51 %FINISH is not required * 8276 FAULT 51 %FINISH is not required 8277 fault(nobegin+now) %if stopper = 0 8278 %if c_access > 0 %start 8279 fault(noresult+now) %if c_type # 0; !fn/map/pred 8280 %finish 8281 close block 8282 %finish * 8282 FAULT 51 %FINISH is not required * 8282 FAULT 51 %FINISH is not required 8283 %end; !GET STATEMENTS 8284 8285 !<|~~~~~~~~~~~~~~~~| 8306 ! |______________| | | 8307 ! | init | | | 8308 ! |~~~~~~~~~~~~~~| |GLOBAL DYNAMICS | 8309 ! | | | | 8310 ! | OWN VALUES | MB->|~~~~~~~~~~~~~~~~| 8311 ! | | | | 8312 ! | | | OWNS | 8313 ! |______________| | | 8314 ! orig| | 8315 ! SP->|~~~~~~~~~~~~~~~~| 8316 ! 8317 8318 reset = 0; totsize = cad 8319 ownsize = ownad 8320 %if ownsize # 0 %start 8321 fill own(4-ownad&3) %if ownad&3 # 0 8322 ownsize = ownad 8323 reset = cad; !entry-point for RESET 8324 totsize = totsize+(initsize+ownad); !total code size 8325 %finish 8326 set extension(objfile,".mob") 8327 time1 = time1-cputime 8328 open output(objout,objfile) 8329 select output(objout) 8330 put word(16_FE02); !object module flag, version 8331 put word(control>>20<<4); !checking options 8332 value = 0 8333 do externals(externs,-1) %if externs # 0; !find size 8334 put word(value); !length of exports 8335 value = 0 8336 do externals(extspecs,-1) %if extspecs # 0; !find size 8337 put word(value); !length of imports 8338 put word(totsize>>16); !length of code + init pattern 8339 put word(totsize) 8340 put word(reset>>1); !reset entry-point 8341 put word(c_dpid_val>>1); !main entry-point 8342 put word(ownsize>>16); !static data requirement 8343 put word(ownsize) 8344 put word(c_totstack>>16); !stack requirement 8345 put word(c_totstack) 8346 put word(0); !spare for diag 8347 put word(0) 8348 put word(0) 8349 put word(0) 8350 do externals(externs,0) %if externs # 0 8351 do externals(extspecs,1) %if extspecs # 0 8352 final(0) = 16_4E; final(1) =16_75; !RTS (as null reset,main?) 8353 i = 0 8354 %cycle 8355 print symbol(final(i)); i = i+1 8356 %repeat %until i = cad 8357 %if ownsize # 0 %start 8358 put word(16_2248+mb-a0); ! move.l mb,a1 8359 put word(16_41FA); ! lea initpatt,a0 8360 put word(16_000E) 8361 put word(16_303C); ! move.w #????,d0 8362 put word(ownad>>1-1); ![individual owns in shortwords - 1] 8363 put word(16_32D8); !l1 move.w (a0)+,(a1)+ 8364 put word(16_51C8); ! dbra d0,l1 8365 put word(-4) 8366 put word(16_4E75); ! rts 8367 i = 0 8368 %cycle 8369 print symbol(final(i+ownbase)); i = i+1 8370 %repeat %until i = ownad 8371 %finish 8372 time1 = time1+cputime 8373 %end 8374 8375 %routine CLOSE EDIT 8376 !_FLAG is negative if edit abandoned 8377 !_CHANGE is untouched (inf) if no changes 8378 %if file(main)_flag >= 0 %and 0 < file(main)_change # 16_7FFFFFFF %start 8379 file(main)_name = mainfile; ![in case modified by OPEN IN] 8380 time1 = time1-cputime 8381 !! disconnect edfile(file(main)) 8382 printstring(file(main)_name." updated"); newline 8383 time1 = time1+cputime 8384 %finish 8385 %end 8386 8387 %begin 8388 %on %event redo,abandon %start 8389 close edit %and %stop %if event_event = abandon 8390 %finish 8391 time2 = cputime-time1 8392 statements = 1; comments = 0; atoms = 0 8393 identatoms = 0; litatoms = 0 8394 faults = 0; others = 0; faultnum = 0 8395 zaps = 0; steps = 0; jumps = 0; shorts = 0 8396 rep = "" 8397 forget triples; !reset LITPOS,EXPLO,OLDEXPLO 8398 char0 = addr(char(0)); final0 = addr(final(0)) 8399 preset 8400 dint == dict(inttype) 8401 dtemp == dict(lablim); dtemp2 == dtemp[1] * Failed to analyse line 8401 DTEMP2==DTEMP[1] ! * Failed to analyse line 8401 DTEMP2==DTEMP[1] ! 8402 dtsprel == dtemp2[1] * Failed to analyse line 8402 DTSPREL==DTEMP2[1] ! * Failed to analyse line 8402 DTSPREL==DTEMP2[1] ! 8403 dmin = dictlim; dmin0 = dmin 8404 inclim = 0 8405 accounted = 0 8406 firstentry = finalbound; firstpos = dictlim 8407 pc = 1; swpc = progbound+1 8408 cad = 2 8409 final(0) = 0; !for empty string (compile-time only) 8410 ownbase = finalbound-4095; ownad = 0 8411 level = outerlevel; vintage = 1 8412 pendout = 0; pendin = 0; polarity = 0 8413 curlab = dictlim+1 8414 reset context(procstar,defaultfree) 8415 c_sp = -4; !allow for BSR 8416 8417 control = initcon 8418 lastfile = main 8419 curfile = main; cur == file(main) 8420 curstart = file(main)_start1; curlim = file(main)_lim1 8421 fp = file(main)_start1 8422 line = 0; sym = nl 8423 np = np0 8424 !<