#if ~(e!d) #report EITHER E OR D MUST BE ENTERED #abort #fi #if e&d #report BOTH E AND D SHOULD NOT BE ENTERED #abort #fi #if e #report PASS1 - EMAS Version #else #report PASS1 - DEIMOS Version %diagnose 1<<14+4096 #fi {###################################################} {# Portable IMP77 compiler First Pass #} {# Copyright: 1 January 1981 #} {# Interactive Datasystems (Edinburgh) Ltd. #} {# 32 Upper Gilmore Place #} {# Edinburgh EH3 9NJ #} {# All Rights Reserved #} {###################################################} %BEGIN #if e %externalintegerspec IMPFLAG %externalroutinespec Define(%string(255) S) #else %systemroutinespec exit(%integer i) %externalroutinespec print ch %alias "PRINTSYMBOL" (%integer S) #fi %CONSTSTRING(4) version = "8.7" !configuration parameters %CONSTINTEGER minus 1 = 16_ffff %CONSTINTEGER max int = ((minus 1)>>1)//10 %CONSTINTEGER max dig = (minus 1)>>1-maxint*10 %CONSTINTEGER byte size = 8 {bits per byte} #if e %CONSTINTEGER max tag = 800 {max no. of tags} %CONSTINTEGER max dict = 6000 {max extent of dictionary} #else %CONSTINTEGER max tag = 200 {max no. of tags} %CONSTINTEGER max dict = 2000 {max extent of dictionary} #fi %CONSTINTEGER name bits = 11 %CONSTINTEGER max names = 1<0 strings, <0 chars} %owninteger end mark = 0 {%end flag} %OWNINTEGER cont = ' ', csym = ' ' {listing continuation marker} %OWNINTEGER decl = 0 {current declarator flags} %OWNINTEGER dim = 0 {arrayname dimension} %OWNINTEGER spec given = 0 %OWNINTEGER escape class = 0 {when and where to escape} %OWNINTEGER protection = 0, atom flags = 0 %OWNINTEGER otype = 0 {current 'own' type} %OWNINTEGER last1 = 0 {previous atom class} %OWNINTEGER gen type = 0 %OWNINTEGER ptype = 0 {current phrase type} %OWNINTEGER papp = 0 {current phrase parameters} %OWNINTEGER pformat = 0 {current phrase format} %OWNINTEGER force = 0 {force next ptype} %OWNINTEGER g = 0, gg = 0, map gg = 0 {grammar entries} %OWNINTEGER fdef = 0 {current format definition} %OWNINTEGER this = -1 {current recordformat tag} %OWNINTEGER nmin = 0 {analysis record atom pointer} %OWNINTEGER nmax = 0 {analysis record phrase pointer} %OWNINTEGER rbase = 0 {record format definition base} %OWNINTEGER stbase = 0 {constant work area base} %OWNINTEGER gmin = max grammar {upper bound on grammar} %OWNINTEGER dmax = 1 %OWNINTEGER tmin = max tag {upper bound on tags} %OWNINTEGER label = 4 %OWNINTEGER ss = 0 {source statement entry} %STRING(63) include file %OWNINTEGER include list = 0, include level= 0 %OWNINTEGER include = 0 {=0 unused, #0 being used} %OWNINTEGER perm = 1 {1 = compiling perm, 0 = program} %OWNINTEGER progmode = 0 {-1 = file, 1 = begin/eop} %OWNINTEGER sstype = 0 {-1:exec stat} ! 0: declaration ! 1: block in ! 2: block out %OWNINTEGER spec mode = 0 {>=0: definition} ! -1: proc spec ! -2: recordformat %OWNINTEGER ocount = -1 {own constants wanted} %OWNINTEGER limit = 0 {lookup limit} %OWNINTEGER copy = 0 {duplicate name flag} %OWNINTEGER order = 0 {out of sequence flag} %OWNINTEGER for warn = 0 {non-local flag} %owninteger Lazy Ercc = 0 %OWNINTEGER dubious = 0 {flag for dubious statements} %OWNINTEGER dp = 1 %OWNINTEGER pos1 = 0, pos2 = 0 {error position} %OWNINTEGER pos = 0 {input line index} %OWNINTEGER dimension = 0 {current array dimension} %OWNINTEGER local = 0 {search limit for locals} %OWNINTEGER fm base = 0 {entry for format decls} %OWNINTEGER search base = 0 {entry for record_names} %OWNINTEGER format list = 0 {size of current format list} %INTEGER recid %OWNBYTEINTEGERARRAY char(0:133) = nl(134) {input line} %INTEGERARRAY lit pool(0:lit max) %OWNINTEGER lit = 0 {current literal (integer)} %OWNINTEGER lp = 0 {literals pointer} %OWNINTEGER block x = 0 {block tag} %OWNINTEGER list = 1 {<= to enable} %OWNINTEGER tty = 0 {non-zero if listing to tty} %OWNINTEGER control = 0 %OWNINTEGER diag = 0 {diagnose flags} %INTEGERARRAY hash(0:max names) %RECORD(tagfm)%ARRAY tag(0:max tag) %INTEGERARRAY dict(1:max dict) %BYTEINTEGERARRAY buff(1:512) %OWNINTEGER bp = 0 !*** start of generated tables *** %include "tables" !*** end of generated tables *** %ROUTINE flush buffer %INTEGER j %IF faulty = 0 %START select output(object) printch(buff(j)) %for J = 1, 1, Bp select output(listing) %FINISH bp = 0 %END %ROUTINE print ident(%INTEGER p, mode) %INTEGER j, ad p = tag(p)_text %IF p = 0 %START bp = bp+1 %AND buff(bp) = '?' %if Mode # 0 %RETURN %FINISH ad = addr(dict(p+1)) %IF mode = 0 %THEN printstring(string(ad)) %ELSE %START %FOR j = ad+1, 1, ad+byteinteger(ad) %CYCLE bp = bp+1 buff(bp) = byteinteger(j) %REPEAT %FINISH %END %ROUTINE abandon(%INTEGER n) %SWITCH reason(0:9) %INTEGER stream stream = listing %CYCLE newline %IF sym # nl printsymbol('*'); write(lines,4); space ->reason(n) reason(0):printstring("compiler error!"); ->more reason(1):printstring("switch vector too large"); ->more reason(2):printstring("too many names"); ->more reason(3):printstring("program too complex"); ->more reason(4):printstring("feature not implemented"); ->more reason(5):printstring("input ended: ") %IF quote # 0 %START %IF quote < 0 %THEN printsymbol(cquote) %C %ELSE printsymbol(squote) %finish %ELSE %start printstring("%endof") %IF progmode >= 0 %THEN printstring("program") %C %ELSE printstring("file") %FINISH printstring(" missing?"); ->more reason(6):printstring("too many faults!"); ->more reason(7):printstring("string constant too long"); ->more reason(8):printstring("dictionary full"); -> more reason(9):printstring("Included file ".include file." does not exist") more: newline printstring("*** compilation abandoned ***"); newline %EXIT %IF stream = report %or tty # 0 stream = report select output(report) %REPEAT #if e IMPFLAG = -Faulty-1 %SIGNAL 14,15 %IF diag&4096 # 0 %STOP #else Exit(Faulty) #fi %END %routine Put Tag(%integer Tag) Buff(Bp+1) <- Tag>>8 Buff(Bp+2) <- Tag Bp = Bp+2 %end %ROUTINE op(%INTEGER code, param) buff(bp+1) <- code buff(bp+2) <- param>>8 buff(bp+3) <- param bp = bp+3 %END %ROUTINE set const(%INTEGER m) buff(bp+1) <- 'N' buff(bp+5) <- m; m = m>>8 buff(bp+4) <- m; m = m>>8 buff(bp+3) <- m; m = m>>8 buff(bp+2) <- m bp = bp+5 %END %ROUTINE compile block(%INTEGER level, block tag, dmin, tmax, id) %INTEGERFNSPEC gapp %ROUTINESPEC delete names(%INTEGER quiet) %ROUTINESPEC analyse %ROUTINESPEC compile %INTEGER open ; open = closed {zero if can return from proc} %INTEGER dbase ; dbase = dmax {dictionary base} %INTEGER tbase ; tbase = tmax {tag base} %INTEGER tstart ; tstart = tmax %INTEGER access ; access = 1 {non-zero if accessible} %INTEGER inhibit ; inhibit = 0 {non-zero inhibits declaratons} %INTEGERNAME bflags ; bflags == tag(block tag)_flags %INTEGER block type ; blocktype = bflags>>4&7 %INTEGER block form ; blockform = bflags&15 %INTEGER block fm ; blockfm = tag(block tag)_format %INTEGER block otype ; blockotype = otype %INTEGERNAME block app ; blockapp == tag(block tag)_app %INTEGER l, new app %ROUTINE fault(%INTEGER n) ! -6 : -1 - warnings ! 1 : 22 - errors %SWITCH fm(-6:22) %INTEGER st %ROUTINE print ss %INTEGER s, p %RETURN %IF pos = 0 space p = 1 %CYCLE printsymbol(marker) %IF p = pos1 %EXIT %IF p = pos s = char(p); p = p+1 %EXIT %IF s = nl %OR (s='%' %AND p = pos) %IF s < ' ' %START {beware of tabs} %IF s = ff %THEN s = nl %ELSE s = ' ' %FINISH printsymbol(s) %REPEAT pos = 0 %IF list <= 0 %END pos1 = pos2 %IF pos2 > pos1 newline %IF sym # nl st = report %IF n = -3 %or tty # 0 %start {unused or listing to console} st = listing Pos = 0 {inhibit PRINT SS} %finish %cycle SELECT OUTPUT(st) %if n < 0 %then printsymbol('?') %and pos1 = 0 %else printsymbol('*') %if st # report %start %if list <= 0 %and pos1 # 0 %start spaces(pos1+margin); PRINTSTRING(" ! ") %finish %finish %else %start PRINTSTRING(include file) %if include # 0 write(lines, 4); printsymbol(csym); space %finish ->fm(n) %if -6 <= n <= 22 PRINTSTRING("fault"); write(n, 2); ->ps fm(-6):Printstring("Record type check fails"); Lazy Ercc = 0; ->nps fm(-5):PRINTSTRING("Dubious statement"); dubious = 0; ->psd fm(-4):PRINTSTRING("Non-local") pos1 = for warn; for warn = 0; ->ps fm(-3):print ident(x, 0); PRINTSTRING(" unused"); ->nps fm(-2):PRINTSTRING("""}"""); ->miss fm(-1):PRINTSTRING("access"); ->psd fm(0): PRINTSTRING("form"); ->ps fm(1): PRINTSTRING("atom"); ->ps fm(2): PRINTSTRING("not declared"); ->ps fm(3): PRINTSTRING("too complex"); ->ps fm(4): PRINTSTRING("duplicate "); Print Ident(Copy, 0);->ps fm(5): PRINTSTRING("type"); ->ps fm(6): PRINTSTRING("match"); ->psd fm(7): PRINTSTRING("context"); ->psd fm(21):PRINTSTRING("context "); print ident(this, 0); ->ps fm(8): PRINTSTRING("%cycle"); ->miss fm(9): PRINTSTRING("%start"); ->miss fm(10):PRINTSTRING("size"); WRITE(lit, 1) %if pos1 = 0;->ps fm(11):PRINTSTRING("bounds") WRITE(ocount, 1) %unless ocount < 0; ->ps fm(12):PRINTSTRING("index"); ->ps fm(13):PRINTSTRING("order"); ->psd fm(14):PRINTSTRING("not a location"); ->ps fm(15):PRINTSTRING("%begin"); ->miss fm(16):PRINTSTRING("%end"); ->miss fm(17):PRINTSTRING("%repeat"); ->miss fm(18):PRINTSTRING("%finish"); ->miss fm(19):PRINTSTRING("result"); ->miss fm(22):PRINTSTRING("format"); ->ps fm(20):printsymbol('"'); print ident(x, 0); printsymbol('"') miss: PRINTSTRING(" missing"); ->nps psd: pos1 = 0 ps: print ss nps: NEWLINE %exit %if st = listing st = listing %repeat %if n >= 0 %start %signal 14,15 %if diag&4096 # 0 %if n # 13 %start {order is fairly safe} ocount = -1 gg = 0 copy = 0; quote = 0 search base = 0; escape class = 0 gg = 0 %finish faulty = faulty+1 !check that there haven't been too many faults fault rate = fault rate+3; abandon(6) %IF fault rate > 30 fault rate = 3 %IF fault rate <= 0 %FINISH tbase = tstart %IF list <= 0 %AND sym # nl %START error margin = column error sym = sym; sym = nl %FINISH %END dmin = dmin-1; dict(dmin) = -1 {end marker for starts & cycles} Dict Upper = Dmin %if Dmin < Dict Upper abandon(2) %IF dmax = dmin %IF list > 0 %AND level > 0 %START write(lines, 5); spaces(level*3-1) %IF block tag = 0 %START printstring("Begin") %FINISH %ELSE %START printstring("Procedure "); print ident(block tag, 0) %FINISH newline %FINISH !deal with procedure definition (parameters) %IF block tag # 0 %START {proc} analyse; compile %IF ss # 0 %IF block otype # 0 %START {external-ish} %IF bflags&spec = 0 %START {definition} %IF progmode <= 0 %AND level = 1 %THEN progmode = -1 %C %ELSE fault(7) %FINISH %FINISH new app = gapp {generate app grammar} %IF spec given # 0 %START {definition after spec} fault(6) %IF new app # block app {different from spec} %FINISH block app = new app {use the latest} %IF level < 0 %START {not procedure definition} delete names(0) %RETURN %FINISH %FINISH %ELSE %START open = 0 {can return from a block?} %FINISH %CYCLE analyse %CONTINUE %IF ss = 0 compile fault(-5) %IF dubious # 0 fault(-6) %if Lazy Ercc # 0 flush buffer %IF bp >= 128 %IF sstype > 0 %START {block in or out} %EXIT %IF sstype = 2 {out} compile block(spec mode, block x, dmin, tmax, id) %EXIT %IF ss < 0 {endofprogram} %FINISH %REPEAT %IF list > 0 %AND level > 0 %START write(lines, 5); spaces(level*3-1) printstring("End") newline %FINISH delete names(0) %RETURN %INTEGERFN gapp {generate app grammar (backwards)} %CONSTINTEGER comma = 140 {psep} %ROUTINESPEC set cell(%INTEGER g, tt) %ROUTINESPEC class(%RECORD(tagfm)%NAME v) %RECORD(tagfm)%NAME v %INTEGER p, link, tp, c, ap, t %RESULT = 0 %IF tmax = local {no app needed} p = gmax1; link = 0; t = tmax %CYCLE v == tag(t); t = t-1 class(v) {deduce class from tag} %IF c < 0 %START {insert %PARAM} c = -c set cell(196, tp) tp = -1 %FINISH set cell(c, tp) %EXIT %IF t = local {end of parameters} set cell(comma, -1) {add the separating comma} %REPEAT abandon(3) %IF gmax > gmin %RESULT = link %ROUTINE set cell(%INTEGER g, tt) !add the cell to the grammar, combining common tails %WHILE p # gmax %CYCLE p = p+1 %IF glink(p) = link %AND gram(p) = g %START %IF tt < 0 %OR (gram(p+1) = tt %AND glink(p+1)=ap) %START link = p {already there} %RETURN %FINISH %FINISH %REPEAT !add a new cell gmax = gmax+1 gram(gmax) = g glink(gmax) = link link = gmax %IF tt >= 0 %START { set type cell} gmax = gmax+1 gram(gmax) = tt glink(gmax) = ap %FINISH p = gmax %END %ROUTINE class(%RECORD(tagfm)%NAME v) %CONSTINTEGER err = 89, rtp = 100, fnp = 101, mapp = 102, predp = 103 %CONSTINTEGERARRAY class map(0:15) = %C err,1764, 247, err(4), -rtp, -fnp, -mapp, -predp, err, 214, err, 229, err %INTEGER tags, type, form ap = 0 tags = v_flags type = tags>>4&7; form = tags&15 tp = v_format<<3!type c = class map(form) c = 208 %AND tp = 0 %IF type = 0 %AND form = 2 {%NAME} ap = v_app %IF tags¶meters # 0 %END %END %ROUTINE delete names(%INTEGER quiet) %INTEGER flags %RECORD(tagfm)%NAME tx Tag Lower = Tmax %if Tmax > Tag Lower %WHILE tmax > tbase %CYCLE x = tmax; tmax = tmax-1 tx == tag(x) flags = tx_flags %if flags&used bit = 0 %start {identifier unused} Fault(-3) %if Quiet = 0 %and {warn unused unless ...} %c Level >= 0 %and {global} %c List <= 0 {no listing} %finish %else %start {identifier used} Fault(20) %if flags&spec # 0 %and flags&own bit = 0 {spec and use with no definition} %finish dict(tx_text) = tx_link %REPEAT %END %ROUTINE analyse %CONSTINTEGER order bits = x'3000', order bit = x'1000' %CONSTINTEGER escape = x'1000' %INTEGER strp, mark, flags, prot err, k, s, c %OWNINTEGER key = 0 %RECORD(arfm)%NAME arp %INTEGER node %INTEGERNAME z %SWITCH act(actions:phrasal), paction(0:15) %ROUTINE trace analysis !diagnostic trace routine (diagnose&1 # 0) %INTEGER a %ROUTINE show(%INTEGER a) %IF 0 < a < 130 %START space printstring(text(a)) %FINISH %ELSE write(a, 3) %END %OWNINTEGER la1=0, la2=0, lsa=0, lt=0 newline %IF mon pos # pos %AND sym # nl mon pos = pos write(g, 3) space printstring(text(class)) printsymbol('"') %IF gg&trans bit # 0 a = gg>>8&15 %IF a # 0 %START printsymbol('{') write(a, 0) printsymbol('}') %FINISH %IF atom1 # la1 %OR atom2 # la2 %OR lsa # subatom %C %OR lt # type %START printstring(" [") la1 = atom1; show(la1) la2 = atom2; show(la2) lsa = subatom; write(lsa, 3) lt = type; write(lt, 5) printsymbol(']') %FINISH newline %END %ROUTINE get sym readsymbol(sym) pos = pos+1 %IF pos # 133 char(pos) = sym printsymbol(sym) %IF list <= 0 column = column+1 %END %ROUTINE read sym %owninteger Last = 0 %CONSTBYTEINTEGERARRAY mapped(0:127) = %C 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, nl, 0, 3 , 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ,'!','"','#', '$', 1 ,'&', 39, '(',')','*','+', ',','-','.','/', '0','1','2','3', '4','5','6','7', '8','9',':',';', '<','=','>','?', '@','A','B','C', 'D','E','F','G', 'H','I','J','K', 'L','M','N','O', 'P','Q','R','S', 'T','U','V','W', 'X','Y','Z','[', '\',']','^','_', '`','A','B','C', 'D','E','F','G', 'H','I','J','K', 'L','M','N','O', 'P','Q','R','S', 'T','U','V','W', 'X','Y','Z', 2 , '|','}','~', 0 !! 0 = space !! 1 = % !! 2 = { !! 3 = ff !! other values represent themselves %IF sym = nl %START s1: lines = lines+1 printsymbol(end mark) %if end mark # 0 s11: pos = 0; pos1 = 0; pos2 = 0; margin = 0; column = 0 Last = 0 end mark = 0 %IF list <= 0 %START %IF include # 0 %START printstring(" &"); write(lines, -4) %FINISH %ELSE write(lines, 5) csym = cont; printsymbol(csym) space %IF error margin # 0 %START lines = lines-1 spaces(error margin) error margin = 0 %IF error sym # 0 %START printsymbol(error sym) pos = 1; char(1) = error sym sym = error sym; error sym = 0 ->s5 %FINISH %FINISH %FINISH s2: symtype = 1 %FINISH s3:readsymbol(sym) pos = pos+1 %IF pos # 133 char(pos) = sym printsymbol(sym) %IF list <= 0 column = column+1 s5:%IF sym # nl %START Last = Sym %RETURN %IF quote # 0 {dont alter strings} sym = mapped(sym&127) %IF sym <= 3 %START {special symbol} ->s2 %IF sym = 0 {space (or dubious control)} symtype = 2 %AND ->s3 %IF sym = 1 {%} cont = '+' %AND ->s11 %IF sym = 3 {ff} !must be { %CYCLE get sym ->s3 %IF sym = '}' ->s4 %IF sym = nl %REPEAT %FINISH key = kdict(sym) %IF key&3 = 0 %AND symtype = 2 %START {keyword} %IF sym = 'C' %AND nextsymbol = nl %START {%C...} getsym; cont = '+'; ->s1 %FINISH %finish %ELSE %start symtype = key&3-2 %FINISH %RETURN %FINISH s4:symtype = quote ->S1 %if last = 0 %and Quote = 0 Cont = '+' %END %INTEGERFN format selected format list = tag(format)_app {number of names} %IF format list < 0 %START {forward ref} atom1 = error+22 %RESULT = 0 %FINISH %IF sym = '_' %START escape class = esc rec search base = tag(format)_format %FINISH %RESULT = 1 %END %ROUTINE code atom(%INTEGER target) %INTEGER dbase, da %INTEGER base, n, mul, pend quote %INTEGER j,k,l, pt %ROUTINE lookup(%INTEGER d) #if e %CONSTINTEGER magic = 6700421 #else %CONSTINTEGER magic = 0421 #fi %INTEGER new name, vid, k1, k2, form %RECORD(tagfm)%NAME t %LONGINTEGER k0 %INTEGER new !first locate the text of the name new = addr(dict(dmax+1)) {K2 = hash value*magic} k0 = magic #if e k1 = (k0*hash value)&X'7FFFFFFF' #else k1 = (k0*hash value)&X'7FFF' #fi k2 = k1>>(32-2*name bits)!1 k1 = k2>>name bits {giving name bits} %CYCLE newname = hash(k1) %EXIT %IF newname = 0 {not in} ->in %IF string(addr(dict(newname+1))) = string(new) k1 = (k1+k2)&max names %REPEAT ! not found spare names = spare names-1 abandon(2) %IF spare names <= 0 hash(k1) = dmax {put it in} dict(dmax) = -1 newname = dmax; dmax = dp; ->not in in: search base = rbase %IF this >= 0 %AND d # 0 {record elem defn} %IF search base # 0 %START {record subname} new = -1 x = search base %CYCLE ->not in %IF x < format list %EXIT %IF tag(x)_text = new name x = x-1 %REPEAT %FINISH %ELSE %START {hash in for normal names} x = dict(newname) ->not in %IF x <= limit {wrong level} %FINISH subatom = x {name found, extract info} t == tag(x) atom flags = t_flags format = t_format; app = t_app protection = atom flags&prot type = atom flags>>4&7; atom1 = amap(atom flags&15) %IF diag&8 # 0 %START printstring("lookup:") write(atom1, 3) write(type, 1) write(app, 3) write(format, 5) write(atom flags, 3) newline %FINISH %IF d = 0 %START {old name wanted} t_flags <- t_flags!used bit search base = 0 %IF atom flags&subname # 0 %AND format # 0 %START {a record} %RETURN %IF format selected = 0 %FINISH %IF atom flags¶meters # 0 %START {proc or array} %IF app = 0 %START {no parameters needed} atom2 = atom1 atom1 = atom1-4 %IF 97 <= atom1 <= 98 %START map gg = atom1; atom1 = var %FINISH %FINISH %ELSE %IF sym = '(' %START search base = 0 {ignore format for now} %IF atom1 >= 106 %START {arrays} app = phrase(app+200) escape class = esc array atom1 = (atom1-106)>>1+91 {a,an->v na,nan->n} %FINISH %ELSE %START {procedures} escape class = esc proc atom1 = atom1-4 %FINISH phrase(200) = app %FINISH pos2 = pos; %return %FINISH !deal with constintegers etc %IF atom flags&const bit # 0 %AND atom1 = var %START map gg = const; atom2 = const subatom = -subatom %IF type = integer %FINISH Escape Class = EscN %if Atom1 = 92 {N} %and Sym = '[' %RETURN %FINISH !new name wanted ->not in %IF tbase # tstart {don't fault proc parm-parm} %IF d = lab+spec+used bit %START t_flags = t_flags!used bit %RETURN %FINISH %IF atom flags&spec # 0 %START {a spec has been given} %IF d = lab %START {define label} t_flags <- t_Flags-Spec %RETURN %FINISH %IF {7 <= decl&15 <= 10 %AND} decl&spec = 0 %START !{procedure} definition after spec %IF (decl!!atom flags)&b'1111111' = 0 %START {correct type?} t_flags = t_flags-spec spec given = 1 %if 7 <= Decl&15 <= 10 {procedure} %RETURN %FINISH %FINISH %IF decl&15 = recfm %START {recordformat} t_flags = record<<4+recfm t_format = fdef %RETURN %FINISH %FINISH %RETURN %IF last1 = jump %AND atom1 = swit copy = x %IF copy = 0 notin:app = 0; vid = 0 atom1 = error+2 %return %if d = 0 {old name wanted} type = d>>4&7; form = d&15; atom1 = amap(form) %IF this < 0 %START {normal scope} new = newname tmax = tmax+1; x = tmax %FINISH %ELSE %START {recordformat scope} new = -1 recid = recid-1; vid = recid tmin = tmin-1; x = tmin format list = tmin %FINISH %IF 11 <= form <= 14 %START {arrays} dim = 1 %IF dim = 0 {set dim for owns} app = dim %FINISH d = d!used bit %IF (otype > 2 %AND d&spec = 0) %OR perm # 0 %OR %c Level = Include Level !external definitions need not be used in the file in which !they are defined, so inhibit a useless unused warning. t == tag(x) %IF form = lab %START id = id+1; vid = id %FINISH t_index = vid t_text = new name t_flags <- d t_app = app t_format = fdef; format = fdef subatom = x %IF new >= 0 %START {insert into hash table} t_link = dict(new); dict(new) = x %IF gmin = max grammar %START {proc param params} tmin = tmin-1; subatom = tmin tag(tmin) = t %FINISH %FINISH abandon(2) %IF tmax >= tmin %END top: pos1 = pos subatom = 0; pend quote = 0; atom flags = 0 {***new***} !app and format must be left for assigning to papp & pformat ->name %IF symtype = -2 {letter} ->number %IF symtype < 0 {digit} %IF symtype = 0 %START atom1 = termin; atom2 = 0 %RETURN %FINISH %IF symtype # 2 %START {catch keywords here} ->text %IF quote # 0 {completion of text} ->strings %IF sym = squote {start of string} ->symbols %IF sym = cquote {start of symbol} ->number %IF sym = '.' %AND '0' <= nextsymbol <= '9' %FINISH !locate atom in fixed dict k = key>>2; read sym %CYCLE j = kdict(k) %EXIT %IF j&x'4000' # 0 %IF j&127 # sym %OR symtype < 0 %START ->err %UNLESS j < 0 k = k+1 %FINISH %ELSE %START l = j>>7&127; read sym %IF j > 0 %START %IF l # 0 %START ->err %IF l # sym %OR symtype < 0 read sym %FINISH l = 1 %FINISH k = k+l %FINISH %REPEAT atom1 = j&127 %IF atom1 = 0 %START {comma} atom1 = 19; subatom = 19; atom2 = 0 %IF sym = nl %START %RETURN %IF ocount >= 0 !special action needs to be taken with as !const array lists can be enormous read sym %FINISH %RETURN %FINISH atom2 = j>>7&127 subatom = kdict(k+1)&x'3fff' !!!!!cont = ' ' %RETURN !report an error. adjust the error marker (pos1) to point !to the faulty character in an atom, but care needs to be taken !to prevent misleading reports in cases like ...????? err: atom1 = error+1; atom2 = 0 pos1 = pos %IF pos-pos1 > 2 %RETURN !take care with strings and symbol constants. !make sure the constant is valid here before sucking it in !(and potentially loosing many lines) symbols:atom1 = var; atom2 = const; type = integer map gg = const; protection = prot subatom = lp; abandon(3) %IF lp >= lit max quote = \pend quote %RETURN !an integer constant is acceptable so get it in and !get the next atom chars:n = 0 %CYCLE read sym Cont = Cquote %IF sym = cquote %START %EXIT %IF nextsymbol # cquote read sym %FINISH %IF n&(\((-1)>>byte size)) # 0 %START { overflow} pos1 = pos; atom1 = error+10; %RETURN %FINISH ->err %IF quote = 0 n = n<top !sniff the grammar before getting the string strings:atom1 = var; atom2 = const; type = stringv subatom = (strp-stbase)!x'4000' map gg = const; protection = prot quote = subatom text line = lines {in case of errors} %RETURN !a string constant is ok here, so pull it in and get !the next atom text: ->chars %IF quote < 0 {character consts} l = strp; n = strp j = addr(glink(gmin-1)) {absolute limit} k = l+256 {string length limit} k = j %IF j < k {choose lower} %CYCLE quote = 1 %CYCLE read sym Cont = Squote %IF sym = squote %START {terminator?} %EXIT %IF nextsymbol # squote {yes ->} read sym { skip quote} %FINISH l = l+1; byteinteger(l) = sym lines = text line %AND abandon(7) %IF l >= k {too many chars} %REPEAT byteinteger(n) = l-n {plug in length} strp = l+1 {ready for next string} quote = 0; cont = ' '; read sym code atom(target) %RETURN %UNLESS atom1 = 48 %AND sym = squote {fold "???"."+++"} %REPEAT %ROUTINE get(%INTEGER limit) %INTEGER s, shift shift = 0 %IF base # 10 %START %IF base = 16 %START shift = 4 %FINISH %ELSE %IF base = 8 %START shift = 3 %FINISH %ELSE %IF base = 2 %START shift = 1 %FINISH %FINISH n = 0 %CYCLE %IF symtype = -1 %START {digit} s = sym-'0' %FINISH %ELSE %IF symtype < 0 %START {letter} s = sym-'A'+10 %FINISH %ELSE %START %RETURN %FINISH %RETURN %IF s >= limit pt = pt+1; byteinteger(pt) = sym %IF base = 10 %START {check overflow} %IF n >= max int %AND (s > max dig %OR n > max int) %START !too big for an integer, !so call it a real base = 0; type = real; n = 0 %FINISH %FINISH %IF shift = 0 %START n = n*base+s %FINISH %ELSE %START n = n<= lit max pt = strp; mul = 0 %CYCLE get(base) %EXIT %UNLESS sym = '_' %AND base # 0 %AND pend quote = 0 {change of base pt = pt+1; byteinteger(pt) = '_' read sym base = n %REPEAT %IF pend quote # 0 %START ->err %IF sym # cquote readsym %FINISH %IF sym = '.' %START {a real constant} pt = pt+1; byteinteger(pt) = '.' read sym type = real; n = base; base = 0; get(n) %FINISH %IF sym = '@' %START {an exponent} pt = pt+1; byteinteger(pt) = '@'; k = pt readsym type = integer; base = 10 %IF sym = '-' %START read sym; get(10); n = -n %FINISH %ELSE %START get(10) %FINISH pt = k+1; byteinteger(pt) = lp; litpool(lp) = n; lp = lp+1 atom1 = error+10 %IF base = 0 type = real {exponents force the type} %FINISH %IF type = real %START byteinteger(strp) = pt-strp subatom = (strp-stbase)!x'2000'; strp = pt+1 %FINISH %ELSE %START litpool(lp) = n lp = lp+1 %FINISH %RETURN name: atom1 = 0 %AND %RETURN %IF 27 <= target <= 41 hash value = 0 !***************************** !*machine dependent for speed* !***************************** dp = dmax+1 da = addr(dict(dp)); dbase = da %CYCLE hash value = hash value+(hash value+sym) {is this good enough?} da = da+1; byteinteger(da) = sym read sym %EXIT %IF symtype >= 0 %REPEAT %IF sym = cquote %START pend quote = 100 ->symbols %IF hash value = 'M' read sym %IF hash value = 'X' %THEN base = 16 %AND ->bxk %IF hash value = 'K' %C %OR hash value = 'O' %THEN base = 8 %AND ->bxk %IF hash value = 'B' %THEN base = 2 %AND ->bxk ->err %FINISH n = da-dbase byteinteger(dbase) = n #if e dp = dp+(n+4)>>2 #else dp = dp+(n+2)>>1 #fi abandon(8) %IF dp >= dmin atom2 = 90 {ident} %IF last1 = 0 %AND sym = ':' %START {label} limit = local; lookup(lab); %RETURN %FINISH %IF last1 = jump %START {->label} limit = local; lookup(lab+spec+used bit); %RETURN %FINISH %IF decl # 0 %AND target = 90 %START {identifier} search base = fm base limit = local; lookup(decl) search base = 0 %FINISH %ELSE %START limit = 0; lookup(0) %FINISH %END %INTEGERFN parsed machine code ! *opcode_?????????? atom1 = error %AND %RESULT=0 %UNLESS symtype = -2 {starts with letter} flush buffer %IF bp >= 128 bp=bp+1; buff(bp)='w' %CYCLE bp=bp+1; buff(bp)=sym read sym %EXIT %IF symtype >= 0 {pull in letters and digits} %REPEAT bp=bp+1; buff(bp)='_' %IF symtype # 0 %START {not terminator} atom1 = error %AND %result=0 %UNLESS sym = '_' read sym %WHILE symtype # 0 %CYCLE %IF symtype < 0 %START {complex} code atom(0); %result=0 %IF atom1&error # 0 %IF atom2 = const %AND type = integer %START %IF subatom < 0 %THEN Set Const(tag(-subatom)_format) %C %ELSE Set Const(litpool(subatom)) %FINISH %ELSE %IF 91 <= atom1 <= 109 %START %if atom1 = 104 {label} %and %c Tag(Subatom)_Flags&Closed = 0 %start This = Subatom; Atom1 = Error+21 %result = 0 %finish op(' ', tag(subatom)_index) %FINISH %ELSE %START atom1 = error; %result=0 %FINISH %FINISH %ELSE %START bp=bp+1; buff(bp)=sym; read sym %FINISH %REPEAT %FINISH bp=bp+1; buff(bp)=';' %RESULT=1 %END %routine Set FTP Arp == Ar(Nmax) X = Arp_X Pos1 = Arp_Pos Pos2 = 0 App = 0 Format = Tag(X)_Format Flags = Tag(X)_Flags Type = Flags>>4&7 Protection = Flags&Prot Protection = 0 %if Flags&Aname # 0 %end %on 9 %start {input ended} Abandon(5) %unless Sstype = -2 {start of statement} Atom1=76; Atom2=0; Subatom = 0 {%endoffile} Sym = NL; Symtype = 0 ->EOF %finish cont = ' ' %IF gg = 0 last1 = 0; mapgg = 0 s = 0; ss = 0; sstype = -2; fdef = 0 fm base = 0 app = 0 !deal with alignment following an error in one statement !of several on a line margin = column {start of statement} pos = 0 stbase = addr(glink(gmax+1)); strp = stbase; lp = 0 tbase = tstart {??????????????} local = tbase %IF gg = 0 %or ocount >= 0 %START {data or not continuation(z)} again:%WHILE sym type = 0 %CYCLE {skip redundant terminators} c = cont cont = ' '; cont = '+' %IF ocount >= 0 read sym cont = c %REPEAT ->skip %IF sym = '!' {comment} this = -1 code atom(0) %IF atom1 = comment %START skip: quote = 1 c = cont read sym %AND cont = c %WHILE sym # nl {skip to end of line} quote = 0; symtype = 0 ->again %FINISH %FINISH decl = 0; mark = 0 gentype = 0; force = 0 dim = 0; prot err = 0 node = 0; nmax = 0; nmin = rec size+1 order = 1; gmin = max grammar+1 sstype = 0 %AND ->more %IF gg # 0 {continuation} ptype = 0; spec given = 0 stats = stats+1; op('O', lines) %IF perm = 0 %AND include = 0 ->fail1 %IF atom1&error # 0 {first atom faulty} %IF escape class # 0 %START {enter the hard way after} g = imp phrase; sstype = -1; ->a3 %FINISH EOF: g = initial(atom1) {pick up entry point} %IF g = 0 %START {invalid first atom} g = initial(0); sstype = 0; ->a3 {declarator?} %FINISH %IF g < 0 %START {phrase imp} g = g&255 nmax = 1 ar(1)_class = 0; ar(1)_link = 0; ar(1)_sub = imp phrase %FINISH gg = gram(g); class = gg&255; sstype = gg>>12&3-1 ->a1 act(194): ptype = type; papp = app; pformat = format; ->more act(196):k =g+1; ->a610 act(188):k = ar(nmax)_sub+1 a610: papp = glink(k) k = gram(k) ->more %IF k = 0 {%NAME} ptype = k&7; pformat = k>>3 act(183):k = type; gentype = k %IF gentype = 0 %OR k = real {%TYPE} %IF pformat < 0 %START {general type} app = papp; format = pformat k = real %IF ptype = real %AND type = integer k = force %AND force = 0 %IF force # 0 %FINISH ->fail2 %UNLESS papp = app %AND (ptype = k %OR ptype = 0) ->more %IF pformat=format %OR pformat = 0 %OR format = 0 %if Ptype = Record %and Control&1 # 0 %start Lazy Ercc = 1 ->More %finish ->fail2 act(197):arp == ar(nmin) k = arp_sub ->fail3 %UNLESS block form = k&15 arp_sub = k>>4 type = block type ptype = block type; pformat = block fm; papp = app pformat = -1 %IF ptype # record ->more act(195):->Fail2 %if Type # 0 %and Type # Integer %and %c Type # Real arp == ar(nmin) k = arp_sub arp_sub = k>>2 k = k&3 !1 = check integer !2 = check real !3 = check real + int ->more %IF k = 0 {0 = no action} %IF k = 1 %START force = integer ->more %IF type = integer %OR type = 0 ->fail2 %FINISH ->fail2 %UNLESS ptype = real %or ptype = 0 {or added?} force = integer %IF k = 3 ->more act(198):!%OTHER k = gg>>8&15 %IF k = 0 %START {restore atom} atom1 = last1 ->more %FINISH %IF k = 1 %START {test string} ->fail2 %UNLESS type = stringv ->more %FINISH %if k = 2 %start {fault record comparisons} ->fail2 %if type = record ->more %finish %if k = 3 %start {check OWN variable coming} code atom(0) ->A7 %if atom flags&own bit = 0 ->more %finish %if k = 6 %start Set FTP Atom1 = 91 {V} ->More %finish for warn = pos1 %IF x <= local {%FORTEST} ->more paction(1):%IF type = record %THEN g = phrase(242) %ELSE pformat = -1 ->a3 paction(2):ptype = real; pformat = -1; ->a3 paction(3):ptype = stringv; pformat = -1; ->a3 paction(4):ptype = integer; pformat = -1; ->a3 paction(5):->a3 %if ptype = integer g = phrase(212) %AND pformat=-1 %IF ptype = real g = phrase(213) %IF ptype = stringv ->a3 paction(6):ptype = gram(ar(nmax)_sub+1)&7; pformat = -1; ->a3 paction(7):ptype=real %IF ptype = integer; pformat = -1; ->a3 a1: last1 = class; atom1 = 0; s = subatom a2: %IF gg&trans bit = 0 %START {insert into analysis record} z == node %CYCLE {insert cell in order} k = z %EXIT %IF gg&order bits = 0 %OR k = 0 gg = gg-order bit; z == ar(k)_link %REPEAT gg = map gg %IF map gg # 0 %AND gg&255 = var nmin = nmin-1; ->fail0 %IF nmin = nmax z = nmin arp == ar(nmin) arp_sub = s; arp_class = (gg&255)!mark arp_link = k %FINISH mark = 0; map gg = 0 more: g = glink(g) {chain down the grammar} paction(0): a3: gg = gram(g); class = gg&255 trace analysis %IF diag&1 # 0 ->a5 %IF class = 0 {end of phrase} %IF class < actions %START {not a phrase or an action} class = atomic(class) %IF class >= figurative ->a2 %IF class >= manifest code atom(class) %IF atom1 = 0 %IF escape class # 0 %START {escape to new grammar} class = escape class; escape class = 0 g = g+escape !note that following an escape the next item is !forced to be transparent! esc: gg = 0 arp == ar(nmax+1) arp_papp = papp; arp_x = x; ->a4 %FINISH ->a1 %IF class = atom1 %OR class = atom2 a7: ->fail1 %IF gg >= 0 {no alternative} g = g+1 ->a3 %FINISH %IF class >= phrasal %START {a phrase} a4: nmax = nmax+1; ->fail0 %IF nmax = nmin arp == ar(nmax) arp_ptype = ptype arp_pos = pos1 arp_pformat = pformat arp_link = gentype arp_class = node arp_sub = g node = 0 g = phrase(class) ptype = force %AND force = 0 %IF force # 0 gentype = 0 ->paction(gg>>8&15) %FINISH ->act(class) {only actions left} a5: !reverse links s = 0 %WHILE node # 0 %CYCLE z == ar(node)_link k = z; z = s; s = node; node = k %REPEAT ss = s a6: %IF nmax # 0 %START k = gentype {type of phrase} arp == ar(nmax); nmax = nmax-1 node = arp_class gentype = arp_link ptype = arp_ptype pformat = arp_pformat g = arp_sub %IF g&escape # 0 %START g = g-escape papp = arp_papp mark = 255 subatom = s ->a3 %FINISH gentype = k %IF gentype = 0 %OR k = real type = gen type k = gg {exit-point code} %CYCLE gg = gram(g) ->a2 %IF k = 0 ->fail1 %IF gg >= 0 {no alternative phrase} k = k-order bit g = g+1 {sideways step} %REPEAT %FINISH Fault(4) %IF copy # 0 fault(13) %IF order = 0 fault(-4) %IF for warn # 0 pos1 = 0 fault rate = fault rate-1 %RETURN act(193):gg = 0 %AND ->a5 %UNLESS sym = '=' %or sym = '<' {cdummy} act(181):atom1 = amap(decl&15) {dummy} ->more act(182):class = escdec; g = glink(g)!escape decl = 0; otype = 0; ->esc {decl} act(199): !compile s = 0 %WHILE node # 0 %CYCLE z == ar(node)_link k = z; z = s; s = node; node = k %repeat ss = s code atom(28) %IF quote # 0 {expend} compile; ->more %IF atom1&error = 0 ->fail1 act(184):->fail4 %UNLESS type = integer %IF subatom < 0 %THEN lit = tag(-subatom)_format %C %ELSE lit = lit pool(subatom) ->fail4 %IF lit # 0 ->more act(185): !apply parameters s = 0 %WHILE node # 0 %CYCLE z == ar(node)_link k = z; z = s; s = node; node = k %REPEAT ss = s atom1 = ar(s)_class; atom2 = 0 atom1 = var %IF atom1 = 97 %OR atom1 = 98 Set FTP %IF flags&subname # 0 %AND format # 0 %START ->fail1 %if format selected = 0 %FINISH Escape Class = EscN %if Atom1 = 92 {N} %and Sym = '[' ->a6 act(187):protection = prot; ->more {%SETPROT} act(186):->More %if protection&prot = 0 prot err = nmin ->A7 act(191):k = protection {%GUARD} code atom(0) protection = k %IF atom flags&aname = 0 ->more act(192):->fail1 %IF parsed machine code=0 ->more act(189):k = gapp {%GAPP} delete names(1) tmax = tbase; tbase = gram (gmin) {restore tmax} local= tbase gmin = gmin+1 x = ar(ar(nmax)_class)_sub tag(x)_app = k {update app} ->more act(180):Atom1 = 45 {Sign} Atom2 = 0 Subatom = 36 {Minus} ->More act(190):gmin = gmin-1 {%LOCAL} abandon(2) %IF gmin <= gmax gram (gmin) = tbase; tbase = tmax local = tbase ->more ! errors fail4:k = error+10; ->failed {*size} fail3:k = error+7; ->failed {*context} fail2:k = error+5; pos2 = 0; ->failed {*type} fail0:k = error+3; ->failed {*too complex} fail1:k = atom1; pos2 = 0 failed: %IF diag&32 # 0 %START printstring("Atom1 ="); write(atom1, 3) printstring(" Atom2 ="); write(atom2, 3) printstring(" subatom ="); write(subatom, 3); newline printstring("Type ="); write(type, 1) printstring(" Ptype ="); write(ptype, 1); newline printstring("App ="); write(app, 1) printstring(" Papp ="); write(papp, 1); newline printstring("Format ="); write(format, 1) printstring(" Pformat ="); write(pformat, 1); newline %SIGNAL 13,15 %FINISH quote = 0 %AND readsym %WHILE sym # nl %AND sym # ';' %IF k&error # 0 %START fault(k&255) %FINISH %ELSE %START %IF prot err = nmin %THEN fault(14) %ELSE fault(0) %FINISH gg = 0; ss = 0; symtype = 0 %END {of analyse} %ROUTINE compile %CONSTINTEGER then = 4, else = 8, loop = 16 %integername Dcon %SWITCH c(0:actions), litop(1:12) %CONSTBYTEINTEGERARRAY operator(1:14) = %C '[', ']', 'X', '/', '&', '!', '%', '+', '-', '*', 'Q', 'x', '.', 'v' %CONSTBYTEINTEGERARRAY cc(0 : 7) = '#','=',')','<','(','>', 'k','t' %CONSTBYTEINTEGERARRAY anyform(0:15) = 1,0,1,1(4),1,0,1,1,0,1,1,1,1 %CONSTINTEGERARRAY decmap(0:15) = %C 1, 2, x'100B', x'100D', x'140C', x'140E', 3, 4, x'1007', x'1008', x'1009', x'100A', 6, 0, 0, 0 %OWNBYTEINTEGERARRAY cnest(0:15) %record(Tagfm)%name T %INTEGER lmode, clab, dupid %INTEGER resln %OWNINTEGER last def = 0 %OWNINTEGER lb, ub %INTEGER cp, ord %INTEGER next, link, j, k, n, done, St Len %INTEGER class %INTEGER lit2, defs, decs, cident %integername PP %INTEGER pending; %OWNINTEGERARRAY pstack(1:40) %OWNSTRING(8) name = "" %OWNINTEGER count = 0 %ROUTINE def lab(%INTEGER l) op(':', l) access = 1 %END %ROUTINE get next %RECORD(arfm)%NAME p gn: %IF next = 0 %START {end of phrase} class = 0 %AND %RETURN %IF link = 0 {end of statement} p == ar(link) next = p_link link = p_sub %FINISH %CYCLE p == ar(next) x = p_sub class = p_class %EXIT %IF class < actions {an atom} %IF x = 0 %START {null phrase} next = p_link; ->gn %FINISH %IF p_link # 0 %START {follow a phrase} p_sub = link; link = next %FINISH next = x %REPEAT next = p_link %IF diag&2 # 0 %START spaces(8-length(name)) %UNLESS name = "" name = text(class) write(x, 2) space printstring(name) space count = count-1 %IF count <= 0 %START count = 5 name = "" newline %FINISH %FINISH %END %ROUTINE set subs(%INTEGER n) !update the app field in n array descriptors %INTEGER p p = tmax %WHILE n > 0 %CYCLE %SIGNAL 14,15 %IF p < tbase tag(p)_app = dimension p = p-1; n = n-1 %REPEAT %END %ROUTINE set bp !define a constant bound pair from the last stacked constants pending = pending-2 lb = pstack(pending+1); ub = pstack(pending+2) %IF ub-lb+1 < 0 %START pos1 = 0; next = link; fault(11) ub = lb %FINISH set const(lb); set const(ub) bp=bp+1 %AND buff(bp)='b' %UNLESS class = 146 %END %ROUTINE compile end(%INTEGER type) ! type = 0:eof, 1:eop, 2:end %IF access # 0 %START open = 0 fault(19) %IF block form > proc {can reach end} %FINISH %WHILE dict(dmin) >= 0 %CYCLE {finishes & repeats} fault(17+dict(dmin)&1) dmin = dmin+1 %REPEAT {delete names(0)} bp=bp+1; buff(bp)=';' bp=bp+1 %AND buff(bp)=';' %IF type = 1 {endofprogram} bflags = bflags!open {show if it returns} %IF type # 2 %START {eop, eof} fault(16) %IF level # type {end missing} %FINISH %ELSE %IF level = 0 %START fault(15) {spurious end} %FINISH end mark = 10 {******Mouses specific******} %END %ROUTINE def(%INTEGER p) !dump a descriptor %INTEGER t, f, type %RECORD(tagfm)%NAME v flush buffer %if bp # 0 defs = defs+1 v == tag(p) t = 0 %UNLESS v_index < 0 %START {no index for subnames} id = id+1 %AND v_index = id %IF v_index = 0 last def = v_index t = last def %FINISH op('$', t) print ident(p, 1) {output the name} t = v_flags type = t type = type&(\(7<<4)) %IF type&(7<<4) >= 6<<4{routine & pred} op(',', type&b'1111111') {type & form} f = v_format f = tag(f)_index %IF t&x'70' = record<<4 f = v_index %IF f < 0 Put Tag(f) {format} f = otype+t>>4&b'1111000' f = f!8 %IF class = 125 {add spec from %DUP} dim = v_app {dimension} dim = 0 %unless 0 < dim <= dim limit Put Tag(f+dim<<8) {otype & spec & prot} defs = 0 %IF t¶meters = 0 f = t&15 %IF v_flags&spec # 0 %START !!!!*why??? v_flags = v_flags&(\spec) %UNLESS 3 <= f <= 10 ocount = -1 {external specs have no constants} %FINISH dimension = 0 %if otype = 2 %and (f=2 %or f=12 %or f=14) %start v_flags = v_flags-1 {convert to simple} %finish %END %ROUTINE def s lab(%INTEGER n) !define a switch label, x defines the switch tag %INTEGER p, l, b, w, bit p = tag(x)_format {pointer to table} l = dict(p) {lower bound} %IF l <= n <= dict(p+1) %START b = n-l w = b>>4+p bit = 1<<(b&15) %IF dict(w+2)&bit # 0 %START {already set} fault(4) %IF pending # 0 %RETURN %FINISH dict(w+2) <- dict(w+2)!bit %IF pending # 0 set const(n) op('_', tag(x)_index) %FINISH %ELSE %START fault(12) %FINISH access = 1 %END %ROUTINE call %RECORD(tagfm)%NAME T t == tag(x) op('@', t_index) access = 0 %IF t_flags&closed # 0 {never comes back} bp=bp+1 %AND buff(bp)='E' %IF t_app = 0 {no parameters} %END %ROUTINE pop def set const(pstack(pending)); pending = pending-1 %END %ROUTINE pop lit %IF pending = 0 %THEN lit = 0 %ELSE %START lit = pstack(pending); pending = pending-1 %FINISH %END %IF sstype < 0 %START {executable statement} %IF level = 0 %START {outermost level} fault(13) {*order} %FINISH %ELSE %START %IF access = 0 %START access = 1; fault(-1) {only a warning} %FINISH %FINISH %FINISH %IF diag&2 # 0 %START newline %IF sym # nl printstring("ss =") write(ss, 1) newline count = 5 name = "" %FINISH next = ss pending = 0; lmode = 0 link = 0; decs = 0 defs = 0; resln = 0; done = 0; St Len = 0 ord = level ord = 1 %IF this >= 0 {recordformat declarations} c(0): top: %IF next # link %START get next; ->c(class) %FINISH !all done, tidy up declarations and jumps newline %IF diag&2 # 0 %AND count # 5 %IF lmode&(loop!then!else) # 0 %START {pending labels and jumps} op('B', label-1) %IF lmode&loop # 0 {repeat} def lab(label) %IF lmode&then # 0 {entry from then} def lab(label-1) %IF lmode&else # 0 {entry from else} %FINISH %RETURN %IF decs = 0 atom1 = error %AND %RETURN %IF atom1 # 0 {%INTEGERROUTINE} order = ord decl = decl&(\15)+decmap(decl&15) {construct declarator flags} atom1 = atoms(decl&15) {generate class} %IF otype # 0 %START {own, const etc.} atom1 = atom1+1 %IF atom1 # proc %IF otype = 2 %START {const} n = decl&15 %if n&1 # 0 %start decl = decl!prot decl = decl!const bit %IF decl&b'1111111' = iform %finish %finish %else %start decl = decl!own bit %FINISH %FINISH sstype = 1 %IF sstype = 0 %AND atom1 = proc atom1 = atom1+1 %IF decl&spec # 0 {onto spec variant} ocount = 0 %AND cont = '+' %IF atom1 = 5 {own array} %IF anyform(decl&15) = 0 %START {check meaningful} %IF decl>>4&7 = record %START this = fdef %IF tag(fdef)_flags&spec # 0 atom1 = error+21 %IF fdef = this {*context for format} %FINISH %if Fdef = 0 %start {*Size ?} Atom1 = Error+10 %unless Otype = 2 %and %c Decl&2_1111 111 = StringV<<4+1 {Permit %Conststring(*) Fred} %finish %FINISH %RETURN atop: access = 0; ->top ! declarators c(88): !rtype c(28): decl = x&(\7) {stype} fdef = x&7 {precision} decs = 1; ->top c(34): !own c(35): otype = x; ord = 1; ->top {external} c(17): pop lit; otype = lit<<8+6; ord = 1; ->top {prim} c(152):decl = decl+x<<1; ->top {xname} c(31): !proc c(32): spec mode = level+1 {fn/map} decl = decl!prot %IF x = 9 {function} c(29): ord = 1 {array} dim = 0 c(30): decl = decl+x {name} decs = 1 ->top c(27): lit = 0 { arrayd} %IF pending # 0 %START pop lit %UNLESS 0 top c(37): x = x!subname {record} c(36): lit = 0 {string} %IF pending # 0 %START pop lit %UNLESS 0 < lit <= 255 %START {max length wrong} atom1 = error+10; %RETURN %FINISH %FINISH fdef = lit {format or length} c(33): decl = x {switch} decs = 1 ->top c(39): decl = decl!spec {spec} ocount = -1 {no initialisation} spec mode = -1 ->top c(38): decl = 64+4 {recordformat (spec)} order = 1 atom1 = x decl = decl!spec %if atom1 = 12 {formatspec} fdef = tmax+1 {format tag} %return c(175):id = id+1; tag(x)_index = id; %return {FSID} c(41): decs = 1; decl = x!spec!closed; ->top {label} c(133):recid = 0; rbase = tmin-1 {fname} this = x fm base = fdef; format list = tmin def(this); ->top c(148):fdef = 0 %AND ->top %IF next = 0 {reclb} get next {skip name} fdef = x ->top c(127):bp=bp+1; buff(bp)='}'; ->top {%POUT} c(126):bp=bp+1; buff(bp)='{'; ->top {%PIN} c(174):set bp {rangerb} c(171): !fmlb c(172): !fmrb c(173):bp=bp+1; buff(bp)='~' bp=bp+1; buff(bp)=class-171+'A'; ->top {fmor} c(168):rbase = -rbase {orrb} sstype = 0; spec mode = 0 c(147):search base = 0 {recrb} tag(this)_app = tmin tag(this)_format = rbase ->top c(45):bp=bp+1 %and buff(bp)='U' %IF x = 36; ->top {sign} c(46):bp=bp+1; buff(bp)='\'; ->top {uop} c(47): !mod c(48): !dot c(42): !op1 c(43): !op2 c(44):bp=bp+1; buff(bp)=operator(x); ->top {op3} !conditions & jumps %ROUTINE push(%INTEGER x) %IF cnest(cp)&2 # x %START cnest(cp) = cnest(cp)!1; x = x+4 %FINISH clab = clab+1 %IF cnest(cp)&1 # 0 cnest(cp+1) = x; cp = cp+1 %END %ROUTINE pop label(%INTEGER mode) lmode = dict(dmin) %IF lmode < 0 %OR lmode&1 # mode %START fault(mode+8) %FINISH %ELSE %START dmin = dmin+1; label = label-3 %FINISH %END c(56): !and c(57):push(x); ->top {or} c(58):cnest(cp) = cnest(cp)!!2; ->top {not} c(138):x = 128+32+16+4 {csep: treat like %WHILE} c(59): !while c(60):%IF class = 138 %THEN op('f', label-1) %C %ELSE def lab(label-1) {until} c(166): !runtil c(62):lmode = (lmode&(else!loop)) !(x>>3) {cword} clab = label; cp = 1; cnest(1) = x&7 ->top c(72):pop label(0) {repeat} def lab(label+1) %IF lmode&32 # 0; ->atop c(69):pop label(1); ->top {finish} c(163): !xelse c(70):pop label(1) {finish else ...} fault(7) %IF lmode&3 = 3 {dangling else} c(68):lmode = (lmode&else)!3 {...else...} %IF access # 0 %START op('F', label-1); lmode = else!3 %FINISH def lab(label) ->top %IF next # 0 c(120): !%MSTART c(67): !start c(71): !cycle stcy: def lab(label-1) %AND lmode = loop %IF lmode = 0{cycle} dmin = dmin-1; abandon(3) %IF dmin <= dmax Dict Upper = Dmin %if Dmin < Dict Upper dict(dmin) = lmode label = label+3 %RETURN c(64):fault(13) %IF dict(dmin) >= 0 %OR inhibit # 0 {on event} inhibit = 1 n = 0 n = x'FFFF' %IF pending = 0 {* = all events} %WHILE pending > 0 %CYCLE pop lit; fault(10) %IF lit&(\15) # 0{too big} j = 1<stcy c(104):op('J', tag(x)_index) {l} inhibit = 1; ->atop c(149):stats = stats-1 {lab} access = 1; inhibit = 1 op('L', tag(x)_index); ->top c(63):j = dmin; l = label {exit, continue} %CYCLE l = l-3 fault(7) %AND ->top %IF dict(j) < 0 %EXIT %IF dict(j)&1 = 0 j = j+1 %REPEAT l = l+1 %IF x = 32 {continue} op('F', l) dict(j) = dict(j)!x {show given} ->atop c(50):bp=bp+1; buff(bp)='C'; ->cop {acomp} c(176):x = 2 {<} c(49): bp = bp+1 %IF next # 0 %START {comparator} buff(bp)='"'; push(0) {double sided} %FINISH %ELSE %START buff(bp)='?' %FINISH cop: x = x!!1 %IF cnest(cp)&2 # 0 {invert the condition} j = cp; l = clab %WHILE cnest(j)&4 = 0 %CYCLE j = j-1; l = l-cnest(j)&1 %REPEAT op(cc(x), l) def lab(clab+1) %IF cnest(cp)&1 # 0 cp = cp-1 clab = clab-cnest(cp)&1 ->top c(78): !fresult c(79): !mresult c(80):open = 0 {return, true, false} access = 0 c(15): {[index]} c(81):bp=bp+1; buff(bp)=x; ->top {monitor} c(82): {stop} c(65):pop lit; op('e', lit) {signal} Fault(10) %unless 0 <= Lit <= 15 ->Atop c(123):Set Const(0); ->Top {%stackz} c(51):bp=bp+1; buff(bp)='S'; ->top {eq} c(53):bp=bp+1; buff(bp)='j'; ->top {jam transfer} c(52):bp=bp+1; buff(bp)='Z'; ->top {eqeq} C(73):Fault(7) %if Level # 0 {Section} Tbase = 0; Tstart = 0 Delete Names(0) Id = 0 List = List+1 Section Lines = Lines; Section Stats = Stats Gmin = Max Grammar; Tmin = Max Tag Perm = 1 #if e Close Stream(Prims) #fi Select input(Prims) #if d Reset Input #fi Bp = Bp+1; Buff(Bp) = 'c' %if Next # 0 %start Get Next; ->Pstr %finish Bp = Bp+1; Buff(Bp) = 0 {null string} %return c(74):%IF level = 0 %START {begin} %IF progmode <= 0 %THEN progmode = 1 %ELSE fault(7) {Permit BEGIN after external defs} %FINISH spec mode = level+1 block x = 0 bp=bp+1; buff(bp)='H'; %RETURN c(77):perm = 0 {endofperm} Lines = Section Lines; Stats = Section Stats select input(source) list = list-1 tbase = tmax; tstart = tmax %RETURN c(76):%IF include # 0 %AND x = 0 %START {end of ...} lines = include; sstype = 0 {include} list = include list include level = 0 include = 0; #if d close input #fi select input(source);! %RETURN #if e close stream(Isource) #fi %return %FINISH ss = -1 {prog/file} c(75):compile end(x); %RETURN {%END} c(85):%IF x=0 %THEN Dcon == control %ELSE Dcon == Diag {control} Dcon = lit&x'3FFF' %IF lit>>14&3 = 1 op('z'-x, lit) ->top c(83):list = list+x-2; ->top {%LIST/%ENDOFLIST} c(86):%IF include # 0 %START {include "file"} fault(7); %RETURN %FINISH get next {sconst} include file = string(x-x'4000'+stbase) %begin %on 9 %start; Abandon(9); %finish #if e Define("ST5,".Include File) #else Open Input(Isource,Include File) #fi %end include = lines; lines = 0 include list = list; include level = level select input(Isource) ->top c(154):dimension = dimension+1 {dbsep} fault(11) %IF dimension = dim limit+1 ->top c(145):set bp; ->top {crb} c(146):set bp {rcrb} c(142): !bplrb dimension = 1 %IF dimension = 0 op('d', dimension); Put Tag(defs) %IF class # 146 %START set subs(defs) fault(13) %IF dict(dmin) >= 0 %OR inhibit # 0 %OR level=0 %FINISH dimension = 0; defs = 0 ->top c(128):id = dupid; ->top {EDUP} c(130):block x = x c(125):dupid = id {%DUP} %return %if Level < 0 {spec about} c(90): def(x); ->top {ident} c(131):T == Tag(X) {cident} %IF T_flags&(b'1111111'+const bit) = iform+const bit %START T_format = lit %FINISH %ELSE %START set const(lit) %IF pending # 0 %if T_Flags&2_111 1111 = StringV<<4+1 %start {Simple string} T_Format = St Len %if T_Format = 0 Fault(10) %if St Len > T_Format %finish def(x) op('A', 1) %FINISH cident = x ->top c(124):dubious = 1 %IF tag(cident)_flags&prot # 0 {%DUBIOUS} ->top c(97): !f c(98): !m c(99): !p c(96): call; ->top {r} c(165): !nlab c(100): !rp c(101): !fp c(102): !mp c(103): !pp c(91): !v c(92): !n c(106): !a c(107): !an c(108): !na c(109): !nan k = tag(x)_index %IF k < 0 %THEN op('n', -k) %ELSE op('@', k) ->top c(121):set const(0); ->top {special for zero} c(167):bp=bp+1; buff(bp)='G'; ->pstr {aconst (alias)} c(const): !const %IF x < 0 %START {constinteger} set const(tag(-x)_format); ->top %FINISH %IF x&x'4000' # 0 %START {strings} bp=bp+1; buff(bp)='''' pstr: x = x-x'4000'+stbase St Len = byteinteger(x) bp=bp+1; buff(bp)=St Len k = St Len+x %CYCLE ->top %IF x = k x = x+1; bp=bp+1; buff(bp)=byteinteger(x) %REPEAT %FINISH %IF x&x'2000' # 0 %START {real} x = x-x'2000'+stbase k = byteinteger(x) op('D', k) k = k+x %CYCLE ->top %IF x = k x = x+1; j = byteinteger(x) %IF j = '@' %START op('@', litpool(byteinteger(x+1))); ->top %FINISH bp=bp+1; buff(bp)=j %REPEAT %FINISH set const(lit pool(x)) ->top c(137):bp=bp+1; buff(bp)='i'; ->top {asep} c(141):bp=bp+1; buff(bp)='a'; ->top {arb} !own arrays c(132):ocount = ub-lb+1 def(x) {oident} dimension = 1; set subs(1) %IF next = 0 %START {no initialisation} op('A', ocount) %IF ocount > 0 ocount = -1 %FINISH %ELSE %START {initialisation given} get next %FINISH ->top c(162):lit = ocount; ->ins {indef} c(143):pop lit {orb} ins: fault(10) %AND lit = 0 %IF lit < 0 get next ->inst c(139): !osep (x=19) c(153):lit = 1 inst: pop def %IF pending # 0 {ownt (x=0)} op('A', lit) ocount = ocount-lit %IF ocount >= 0 %START ->top %IF x # 0 {more coming} ocount = -1 %and %RETURN %IF ocount = 0 {all done} %FINISH fault(11); %RETURN c(swit):op('W', tag(x)_index); inhibit = 1; ->atop c(134):def(x) {swid} n = ub-lb+1 n = (n+15)>>4 {slots needed (includes zero)} j = dmax; dmax = dmax+n+2 abandon(1) %IF dmax >= dmin tag(x)_format = j dict(j) = lb; dict(j+1) = ub %CYCLE n = n-1 ->top %IF n < 0 j = j+1; dict(j+1) = 0 %REPEAT c(151):stats = stats-1 {slab} fault(7) %AND %RETURN %IF x < tbase %IF pending # 0 %START {explicit label} def s lab(pstack(1)) %FINISH %ELSE %START fault(4) %AND %RETURN %IF tag(x)_app # 0 tag(x)_app = 1 n = tag(x)_format %FOR j = dict(n), 1, dict(n+1) %CYCLE def s lab(j) flush buffer %IF bp >= 128 %REPEAT %FINISH inhibit = 1 %RETURN c(140):bp=bp+1; buff(bp)='p'; ->top {psep} c(144):buff(bp+1)='p'; buff(bp+2)='E'; bp=bp+2; ->top {prb} !constant expressions c(155): !pconst %IF x < 0 %THEN lit = tag(-x)_format %c %ELSE lit = lit pool(x) pending = pending+1 Set Lit: Pstack(Pending) = Lit; ->top c(156):Lit = pstack(pending); Lit = -Lit %IF Lit < 0; ->SetLit {cmod} c(157):Lit = pstack(pending); Lit = -Lit; ->SetLit {csign} c(158):Lit = pstack(pending); Lit = \Lit; ->SetLit {cuop} c(159): {cop1} c(160): {cop2} c(161):pending = pending-1 {cop3} lit = Pstack(Pending) lit2 = pstack(pending+1) ->litop(x>>2) litop(10):Lit = Lit*lit2; ->SetLit litop(12): litop(3):n = 1 {lit = lit\\lit2} fault(10) %IF lit2 < 0 Lit2 = Lit2-1 %and N = N*Lit %WHILE lit2 > 0 Lit = n; ->SetLit litop(1):Lit = Lit<SetLit litop(2):Lit = Lit>>lit2; ->SetLit litop(5):Lit = Lit&lit2; ->SetLit litop(11): litop(4):%IF lit2 = 0 %THEN fault(10) %ELSE Lit = Lit//lit2 ->SetLit litop(8):Lit = Lit+lit2; ->SetLit litop(9):Lit = Lit-lit2; ->SetLit litop(6):Lit = Lit!lit2; ->SetLit litop(7):Lit = Lit!!lit2; ->SetLit c(170):Fault(4) {%if IMPCOM_Option # ""} !!! IMPCOM_Option = String(x-x'4000'+Stbase) {Option string} ->Top !string resolution c(135):resln = 2; ->top {dotl} c(136):resln = resln+1; ->top {dotr} c(55): op('r', resln); resln = 0; ->top {resop} c(164):op('r', resln+4); resln = 0 {cresop} c(122):x = 6; ->cop {%PRED} c(87): set const(pstack(1)) {mass} bp=bp+1; buff(bp)='P'; ->top %END %END {of compile block} {list = 15 %IF Impcom_Flags&x'1000' # 0} tty = 0 selectinput(2); selectoutput(listing) tag(max tag) = 0 {%BEGIN defn} tag(0) = 0; tag(0)_flags = 7 {%BEGIN tag!} Hash(x) = 0 %FOR x = 0, 1, max names printstring(" Lattice Logic IMP77 Compiler - Version "); printstring(version) newlines(2) op('l', 0) compile block(0, 0, max dict, 0, 0) bp=bp+1; buff(bp)=nl {for bouncing off} flush buffer %if Diag&4096 # 0 %start Select Output(0) Printstring("Tags: "); Write(Tag Lower, 0); Write(Tmin, 1); Newline Printstring("Dict: "); Write(Dmax, 0); Write(Dict Upper, 1); Newline Printstring("Gram: "); Write(Gmax, 0); Write(Gmin, 1); Newline %finish #if e IMPFLAG=Stats IMPFLAG=~Faulty %if Faulty # 0 #else %if Faulty # 0 %then Exit(Faulty) %else %start select output(0) write(stats,1) printstring(" lines compiled") newline %finish #fi *lm_4,15,16(10) *bcr_15,15 %endofprogram