// COSYN - the syntax analyser for the RMCS Coral compiler // This computer software is Crown Copyright 1975 // // Version 7.50 // // February 1982 // // Robert Firth RMCS Shrivenham GET "COSYN7.HDR" || NextSymb ( ) : Symbol || -------- || || This function reads the next basic symbol from the input and || returns it as result. || || It may set the following globals || || Symb : Symbol always set to the next symbol (ie same as result) || Decval : Number value of number or literal || Octval : Number value of octal number || Notoct : Bool TRUE if number just read contained nonoctal digit || Charv : Vector value of name, string, or floating number (unpacked) || Charp : Index highest index of Charv used by value || Wordv : String ditto, packed || Wordsize: Index highest index of Wordv used by packed value || Wordnode: Treecell ditto, stored in tree || || The function may also change input streams &c while scanning for || the next symbol || || Since there are several syntactic constructions in Coral that are || treated as Comment, the previous lexical token is saved in || || OldSymb : Symbol || || and any number of subsequent comment sequences do not change it LET nextsymb() = VALOF { LET oldsymb = symb { LET tagt = primes->4,1 AND s = nil WHILE 0<=ch<='*S' DO rch() symb := VALOF SWITCHON ch INTO { CASE '0':CASE '1':CASE '2':CASE '3':CASE '4': CASE '5':CASE '6':CASE '7':CASE '8':CASE '9': symb := rdtag(2) TEST symb=s.number /\ charv!0<=2*bytesperword THEN wordnode := nil //small integer OR lookupword(symb) BREAK CASE '*'': rch() CASE 'a': CASE 'b': CASE 'c': CASE 'd': CASE 'e': CASE 'f': CASE 'g': CASE 'h': CASE 'i': CASE 'j': CASE 'k': CASE 'l': CASE 'm': CASE 'n': CASE 'o': CASE 'p': CASE 'q': CASE 'r': CASE 's': CASE 't': CASE 'u': CASE 'v': CASE 'w': CASE 'x': CASE 'y': CASE 'z': tagt := tagt-1 CASE 'A': CASE 'B': CASE 'C': CASE 'D': CASE 'E': CASE 'F': CASE 'G': CASE 'H': CASE 'I': CASE 'J': CASE 'K': CASE 'L': CASE 'M': CASE 'N': CASE 'O': CASE 'P': CASE 'Q': CASE 'R': CASE 'S': CASE 'T': CASE 'U': CASE 'V': CASE 'W': CASE 'X': CASE 'Y': CASE 'Z': rdtag(tagt) UNLESS tagt=4 DO s := findsysword(wordv) IF s = nil DO { IF tagt=3 DO caereport(61+e.skip) IF oldsymb=s.rsect LOOP symb := lookupword(s.name) s := findfp(wordnode) UNLESS s=nil DO { newframe('~',s,0,lastfp!0,mstacktop) rch() LOOP } UNLESS macroexpand BREAK s := findmacro(wordnode) IF s=nil BREAK UNLESS h4!s=0 DO lookfor(s.lparen,86) { LET m = mstacktop LET f = copyparams(s) newframe('@',h3!s+1,0,f,m) rch() LOOP } } symb := s IF symb=s.define \/ symb=s.delete DO { macroexpand := FALSE nextsymb() { TEST s=s.define THEN addmacro() OR delmacro() } REPEATWHILE nextis(s.comma) UNLESS symb=s.semicolon DO caereport(87+e.return) macroexpand := TRUE LOOP } IF symb=s.get DO { performget(); LOOP } IF symb=s.comment DO { skipto(';'); LOOP } IF symb=s.lit DO { lookfor(s.lparen,86) IF ch=escapechar DO escape() decval,wordnode := ch,nil UNLESS rch()=')' DO caereport(85+e.skip) RESULTIS s.number } oct: IF nextis(s.oct) DO { LET sw = nextis(s.lparen) UNLESS symb=s.number DO caereport(97+e.skip) IF notoct DO caereport(93+e.return) decval := octval IF sw DO lookfor(s.rparen,85) symb,wordnode := s.number,nil BREAK } IF symb=s.notimp DO caereport(99+e.return) UNLESS symb=s.end BREAK DEFAULT: UNLESS symb=s.end \/ ch<0 DO { rch(); caereport(94+e.return); LOOP } IF mstacktop=treevec DO { symb := s.end; BREAK } IF sourcebuff=nil DO endread() mstacktop := mstacktop-5 oldch,sourcebuff,sourceptr,currfp,mstacktop := h1!mstacktop,h2!mstacktop,h3!mstacktop,h4!mstacktop,h5!mstacktop ch := oldch IF sourcebuff=nil DO selectinput(sourceptr) IF sourcelist DO listing := mstacktop=treevec->TRUE,macrolist LOOP CASE '[': RESULTIS s.bra CASE ']': RESULTIS s.ket CASE '(': IF oldsymb=s.semicolon DO UNLESS nobracom DO { skipto(')'); LOOP } RESULTIS s.lparen CASE ')': RESULTIS s.rparen CASE '#': symb := s.oct; rch(); GOTO oct CASE '$': IF rch()=escapechar DO escape() decval := ch RESULTIS s.number CASE '+': RESULTIS s.plus CASE '-': RESULTIS s.minus CASE ',': RESULTIS s.comma CASE ';': RESULTIS s.semicolon CASE '{': skipto('}'); LOOP CASE '=': RESULTIS s.eq CASE '^': RESULTIS s.loc CASE '**': RESULTIS s.mult CASE '/': RESULTIS s.slash CASE '%': RESULTIS s.div CASE '.': rch(); LOOP CASE'<': IF oldsymb=s.semicolon DO { skipto('>'); LOOP } IF rch()='=' RESULTIS s.le IF ch='>' RESULTIS s.ne IF ch='<' RESULTIS s.lshift symb := s.ls BREAK CASE '>': IF rch()='=' RESULTIS s.ge IF ch='>' RESULTIS s.rshift symb := s.gr BREAK CASE ':': IF rch()='=' DO CASE '_': RESULTIS s.ass symb := s.colon BREAK CASE '*"': charp := 0 UNTIL rch()='*"' \/ ch='*N' \/ charp>=255 DO { IF ch=escapechar DO { escape(); IF ch=('*N'\/#200) LOOP } charp,charp!charv := charp+1,ch } UNLESS ch='*"' DO caereport(95+e.return) charv!0 := charp wordnode := newvec(charp/bytesperword + 1) wordnode!0 := s.string packstring(charv,wordnode+1) RESULTIS s.string } rch(); BREAK } REPEAT RESULTIS symb } || Skipto ( k : Char ) || ------ || || Skips the current input until either an i/o error or the || first proper occurrence of char K. || || Used to skip Coral comment, and for some error recovery in lexis || || The possible terminators are || || ';' COMMENT sentences || ')' bracketed comment || '}' nonstandard bracketed comment, and error recovery in CODE || '>' likewise || '"' error recovery in strings || || If the terminator is ')', ie if we are in Coral bracketed comment, || then any nested (..) sequences are skipped || || Nested {..} sequences are always skipped || || The escape convention applies if the terminator is '}', || ie within {..}, but not otherwise || || The terminator is the last char skipped AND skipto(k) BE { IF ch=k \/ ch<0 DO { rch(); RETURN } IF ch=escapechar /\ k='}'Do rch() IF rch()='(' /\ k=')' DO skipto(')') IF ch='{' DO skipto('}') } REPEAT || Escape ( ) || ------ || || Called to implement the Escape convention, after recognising the || escapechar on input. || || Reads the next char, inspects it, and sets global Ch to the correct || value denoted by the escape sequence || || The escape conventions are || || ec N -> *N || ec S -> *S || ec T -> *T || ec P -> *P || ec B -> *B || ec *N -> *N \/ #200 || ec k -> k AND escape() BE { LET c = rch() ch := c='N'->'*N', c='S'->'*S', c='T'->'*T', c='P'->'*P', c='B'->'*B', c='*N'->'*N'\/#200, c } . GET "COSYN7.HDR" // Replaced by PDP-11 machine code routine FindSysWord // RJF 1 Nov 75 //AND D(S, ITEM) BE $( UNPACKSTRING(S, CHARV) // WORDSIZE := PACKSTRING(CHARV, WORDV) // LOOKUPWORD(ITEM) // $) // //AND DECLSYSWORDS() BE //$( // D('WHILE',S.WHILE) // D('INFINITY',S.INFIN) // D('DELETE',S.DELETE) // D('BITS',S.BITS) // D('ARRAY',S.ARRAY) // D('AND', S.LOGAND) // D('ABSOLUTE',S.ABSOLUTE) // D('ANSWER',S.RESULTIS) // D('BEGIN',S.LSECT) // D('BIT',S.COMMA) // D('COMMENT',S.COMMENT) // D('BYTE',S.BYTE) // D('CODE',S.CODE) // D('COMMON',S.GLOBAL) // D('DEFINE',S.DEFINE) // D('FINISH',S.END) // D('ELSE',S.ELSE) // D('DIFFER',S.DIFFER) // D('DO',S.DO) // D('END',S.RSECT) // D('EXTERNAL',S.EXTNAME) // D('FOR',S.FOR) // D('FIXED',S.NOTIMP) // D('FLOATING',S.FLO) // D('GOTO',S.GOTO) // D('IF',S.IF) // D('PROCEDURE',S.PROC) // D('MASK',S.MASK) // D('LIBRARY',S.GET) // D('IS',S.EQ) // D('INTEGER',S.INT) // D('LABEL',S.LABEL) // D('LITERAL',S.LIT) // D('LOCATION',S.LOC) // D('OR',S.LOGOR) // D('MOD',S.REM) // D('OCTAL',S.OCT) // D('OVERLAY',S.OVERLAY) // D('PRESET',S.NOTIMP) // D('UNION',S.UNION) // D('SWITCH',S.SWITCH) // D('RECURSIVE',S.PROC) // D('STEP',S.STEP) // D('TABLE',S.TABLE) // D('THEN',S.THEN) // D('VALUE',S.VAL) // D('UNTIL',S.UNTIL) // D('UNSIGNED',S.UNSIGNED) // D('WITH',S.WITH) // $) // || LookUpWord ( t : Symbol ) : Symbol || ---------- || || This function stores an input identifier or number in the Tree || || The input parameter is the Coral basic Symbol that the object is || supposed to be an instance of, and the result is the same, but || extracted from any previous occurrence of the object || || The function uses the following globals || || Namevec : Vector the list of hash chain heads on which the || strings are linked || Wordv : String on input, the string to be stored || Wordsize: Index the highest index of Wordv used || Wordnode: Treecell on exit, the cell where the string is stored || || The strings are stored in cells of the form || || ( Symbol , Link , Text ) || || The text is hashed to index one of the list ptrs in NameVec, and || the cells are linked on each list in lexicographic order, || each unique text occurring once LET lookupword(t) = VALOF { LET hashval = ( (charv!0<<4) + (charv!1<<2) + charv!charp ) REM namevecsize LET m = namevec + hashval { wordnode := RV m IF wordnode=nil BREAK { LET p = comparestring(wordnode+2,wordv) IF p=0 RESULTIS wordnode!0 IF p>0 BREAK } m := wordnode+1 } REPEAT wordnode := newvec(wordsize+2) wordnode!0, wordnode!1 := t, RV m RV m := wordnode FOR i=0 TO wordsize DO wordnode!(i+2) := wordv!i RESULTIS t } || Macro Processing || ----- ---------- || || The Coral macroprocessor is an integral part of lexical scansion || || It uses the following globals || || Macrochain : Treecell list of macro definition cells in || reverse order of definition || Mstacktop : Ptr first free word in macro expansion stack || Sourcebuff : Ptr string that is current input source || (NIL if not in macro expansion) || Sourceptr : Index last char read of current Sourcebuff || (input stream if not in macro expansion) || Currfp : Ptr list of current macro formals in scope || Lastfp : Ptr ptr into Currfp list at point where a || formal has just been identified || || The macro expansion stack uses TreeVec from the bottom up || || A macro definition cell is stored in the tree and has the form || || ( link to previous macro, || ptr to macro name, || ptr to macro body, || number of formals, || ptr to first formal, || ... || ) || || A formal parameter cell is stored on the macro expansion stack, || || ( link to previous cell, || ptr to 'number of formals' cell in current macro, || ptr to first actual, || ... || ) || || The actuals are BCPL strings copied from input onto the macro || expansion stack || || Each nested level of macro expansion, argument substitution, or || Library file processing stacks the current lexical environment || on the macro expansion stack thus || || ( last char read from old source, || previous Sourcebuff, || previous Sourceptr, || previous Currfp chain head, || previous value of Mstacktop || ) || || AddMacro ( ) || -------- || || Adds a macro definition to the dictionary || || Reads the macro name, formal arguments if any, and body || Constructs a macro definition cell || Adds it at the front of MacroChain AND addmacro() BE { LET v = VEC 255 AND f = h4 h1!v, h2!v := macrochain,rname() IF nextis(s.lparen) DO { f,v!f := f+1,rname() REPEATWHILE nextis(s.comma) checkfor(s.rparen,85) } h3!v,h4!v := wordnode,f-h4 checkfor(s.string,68) macrochain := newvec(f) FOR i=0 TO f DO macrochain!i := v!i } || FindMacro ( n : Name ) : Treecell || --------- || || Searches the Macrochain for the first occurrence of a macro with || the given name, and returns a ptr to its definition cell, or NIL || if none is found AND findmacro(n) = VALOF { LET m = macrochain UNTIL m=nil \/ h2!m=n DO m := h1!m RESULTIS m } || DelMacro ( ) || -------- || || Called to delete a macro || || Reads the macro name from input and attempts to find the macro || If it succeeds, sets the 'ptr to name' in the definition cell || to NIL, preventing any subsequent recognition of the macro AND delmacro() BE { LET m = findmacro(rname()) TEST m=nil THEN caereport(66+e.return) OR h2!m := nil } || NewFrame ( c : Char ; (free value used only in listing) || -------- sb : Ptr ; (new Sourcebuff) || sp : Index; (new Sourceptr) || f : Ptr; (new Currfp) || ms : Ptr; (old Mstacktop) || ) || || Called to set up a new lexical environment with the given parameters || || The old environment is stacked || || The listing flag is changed as appropriate: Library files are || never listed, macro expansions are listed if the option has || been selected || || The parameter F may be either a valid Ptr (including NIL), or || the value -1 to indicate that no change of current macro formals || is required AND newframe(c,sb,sp,f,ms) BE { LET m = mstacktop mstacktop := mstacktop+5 IF compareaddress(mstacktop,treep)>=0 DO caereport(98+e.stop) h1!m,h2!m,h3!m,h4!m,h5!m := oldch,sourcebuff,sourceptr,currfp,ms oldch,sourcebuff,sourceptr := c,sb,sp listing := sourcebuff=nil -> FALSE, macrolist UNLESS f=-1 DO currfp := f } || Findfp ( n : Name ) : String || ------ || || Called to check whether a given Name is a macro formal argument || currently in scope || || If it is, returns a pointer to the corresponding actual, which is || a BCPL string || || If it is not, returns NIL || || As a side effect, sets Lastfp to the formal cell containing the || name actually found AND findfp(n) = VALOF { lastfp := currfp { IF lastfp=nil RESULTIS nil { LET f = h2!lastfp FOR i=1 TO f!0 DO IF f!i=n RESULTIS lastfp!(i+1) lastfp := h1!lastfp } } REPEAT } || CopyParams ( m : Treecell ) : Ptr || ---------- || || Called to copy an actual macro argument sequence from current input || onto the macroexpansion stack || || The macro whosse arguments are required in passed as M, a pointer to || the macro definition cell || || The result returned is the formal argument context in which the macro || expansion is to be performed || || COPYPARAMS() checks the number of formals, and if there should be none || it copies nothing and returns -1 to indicate no change of formal || argument context is required. || || Otherwise, it attempts to copy the correct number of formals, sets up || a new formal argument cell cahined on to the front of the current || formal list, and returns it as result AND copyparams(m) = VALOF { LET cp() = VALOF { LET p = 0 AND s,t,q,r = 0,0,FALSE,FALSE { IF p>255 DO { caereport(63+e.return); BREAK } TEST q THEN TEST ch=escapechar THEN { p,charv!p := p+1,ch; rch() } OR IF ch='*"' DO q := FALSE OR TEST r THEN IF ch='*'' DO { r := FALSE; GOTO ll } OR TEST ch=',' /\ s=0 /\ t=0 THEN BREAK OR TEST ch='(' THEN s := s+1 OR TEST ch='[' THEN t := t+1 OR TEST ch=')' THEN { IF s=0 BREAK; s := s-1 } OR TEST ch=']' THEN { IF t=0 BREAK; t := t-1 } OR TEST ch='*'' THEN UNLESS primes DO { r := TRUE; GOTO ll } OR IF ch='*"' DO q := TRUE p := p+1 p!charv := ch ll: rch() } REPEAT charv!0 := p p := mstacktop mstacktop := mstacktop + (packstring(charv,p)+1) RESULTIS p } LET n = h4!m AND p = 0 IF n=0 RESULTIS -1 p := mstacktop n,h1!p := n+1,currfp h2!p := m+h4; mstacktop := mstacktop + (n+1) FOR i=2 TO n DO { p!i := cp() UNLESS ch=(i=n->')',',') DO { mstacktop := p caereport(ch=')'\/ch=','->62+e.skip,67+e.skip) } rch() } RESULTIS p } . GET "COSYN7.HDR" || Char Input and Listing || ---- ----- --- ------- || || This module uses the following globals || || Listing : Bool TRUE if a source listing is to be produced || Sourcebuff: Ptr source of input (NIL if a file) || Sourceptr: Index index to current source (stream no. if a file) || Chbuf : Vector circular buffer holding last few chars read || by lexical scanner, regardless of source || Chcount : Number running count of chars read (wraparound safe) || Ch : Char last char read || Oldch : Char next to last char read || Linecount: Number the number of the current source line || || The Boolean LISTING is set if the current input is to be listed. || This will be so if the option has been selected and if input is || from the primary source file || Rch ( ) : Char || --- || || Steps one character || || Since the lexis is LR(1), and reads one character beyond each || symbol, there is a two character buffer in the read system || || The next to last char is in OLDCH, and the last char in CH || || To step the input, it is necessary to || || perform listing action for OLDCH || copy CH into OLDCH || read next char into CH || store char read at next cell in CHBUF circular buffer || return char as result || || The listing action applies only if the appropriate option is selected, || and if the primary input file is the present source of input, and consists || of either just writing the char or, in the case of a newline, incrementing || the line number and printing a new line and its number || || The source of input may be a file or an internal string LET rch() = VALOF { chcount := chcount+1 IF listing DO wrch(oldch) chbuf!(chcount/\chbufsize) := oldch IF oldch='*N' DO { IF mstacktop=treevec DO linecount := linecount+1 IF listing DO { chcount := 0; writef("*T%I4*T",linecount) } } ch := sourcebuff=nil -> rdch(), sourceptr=stringlength(sourcebuff) -> endstreamch, VALOF { sourceptr := sourceptr+1 RESULTIS getbyte(sourcebuff,sourceptr) } oldch := ch RESULTIS ch } || Wrchbuf ( ) || ------- || || Called before a syntax error message is printed || || If a listing is currently being produced, then the current line is || broken and a flag is put at the left. || Otherwise, the circular buffer upto the point of the error is printed AND wrchbuf() BE TEST listing THEN writes("*N***S") OR { newline() FOR i=chcount-chbufsize TO chcount DO wrch(chbuf!(i/\chbufsize)) writef("*NError in %S near source line %N : ", sourcebuff~=nil -> "macro expansion", mstacktop=treevec-> "input file", "LIBRARY", linecount) } || RdTag ( t : Number ) : Symbol || ----- || || This function reads an identifier, language word, or number || || The parameter is the type of symbol expected, and the result is the || symbol found || || Several globals are also set || || Charv : Vector the text of the symbol, unpacked || Charp : Index the highest index of Charv used || Wordv : Vector symbol text, packed || Wordsize: Index the highest index of Wordv used || Decval : Number the binary value of a decimal string || Octval : Number the binary value of an octal string || Notoct : Bool TRUE if the string contained '8' or '9' || || The symbol text is not stored, but simply left in the vectors || RdTag will read system words, identifiers, integers and floating || numbers. The latter will also have a pseudointeger ('fixed') form || calculated, for use by COTAN when compile-time fixing is required. || The fixed value may not be correct, especially if the compilation is || done on a different machine, but it is required by the OD. || || Parameter T indicates type of thing expected thus: || || 0: identifier (lower case) || 1: system word (upper case) || 2: number || 3: system word (upper case stropped) || 4: identifier (upper case unstropped) AND rdtag(t) = VALOF { LET s = 1 AND tp,dp,ep = 0,0,0 charp,charv!1 := 1,ch decval,octval,notoct := ch-'0',decval,FALSE //just in case { LET c = rch()-'0' TEST 0<=c<=9 THEN { s := s\/1 decval,octval := decval*10+c,(octval<<3)+c IF c>7 DO notoct := TRUE } OR TEST ch='*S' /\ t~=1 THEN LOOP OR TEST t=1 \/ t>=3 THEN UNLESS 'A'<=ch<='Z' BREAK // system word? OR TEST t=0 THEN UNLESS 'a'<=ch<='z' BREAK // identifier? OR TEST ch='.' THEN { UNLESS s=1 GOTO err; dp,s := charp+1,2 } OR TEST ch='\' THEN { UNLESS s=1 \/ s=3 GOTO err ep,tp,decval,s := charp,1,0,4 } OR TEST ch='+' \/ ch='-' THEN { UNLESS s=4 BREAK; IF ch='-' DO tp := -1; s := 6 } OR BREAK charp := charp+1; charv!charp := ch } REPEAT IF t=3 DO TEST ch='*'' THEN rch() OR caereport(94+e.skip) IF t=0 /\ ch='.' DO rch() IF (s/\1) = 0 DO err: caereport(93+e.skip) charv!0 := charp wordsize := packstring(charv,wordv) IF t=2 DO //calculate pseudointeger { LET cp = charp IF s=1 RESULTIS s.number tp := tp*decval UNLESS ep=0 DO cp := ep TEST dp=0 THEN dp := cp+1 OR { cp := cp-1; FOR i=dp TO cp DO charv!i := charv!(i+1) } dp := dp+tp // DP is now inplicit fractional point decval := 0 FOR i=1 TO dp-1 DO { decval := decval*10 UNLESS i>cp DO decval := decval + (charv!i-'0') } RESULTIS s.flonum } // result is in DECVAL } || PerformGet ( ) || ---------- || || Called to open a LIBRARY and change lexical context as appropriate || || The routine expects to find a valid filename as a string in the || current input || || The file is opened, the current context stacked on the macro expansion || stack, and the lexical environment variables adjusted. The first char || of the new source is read AND performget() BE { lookfor(s.string,68) newframe(0,nil,findinput(wordnode+1),-1,mstacktop) IF sourceptr<0 DO caereport(64+e.stop) selectinput(sourceptr) rch() } || Free Storage Routines || ---- ------- -------- || || These routines claim storage from TREEVEC downwards from top to bottom || || The pointer TREEP indicates the last cell used, and this is lowered when || more store is claimed || || Since the macro expansion stack grows upwards from the bottom of TREEVEC, || free storage is exhausted when TREEP passes MSTACKTOP || || Note that this test is on Addresses, so in order for it to be portable the || library routine CompareAddress must be used || || All the routines return the address of the word lowest in store of the || area they have claimed || Newvec ( n : Number ) : Ptr || ------ || || Claims a cell of size n+1 -ie indexed from 0 to n- and returns its address AND newvec(n) = VALOF { treep := treep - (n+1) UNLESS compareaddress(treep,mstacktop)<=0 RESULTIS treep caereport(98+e.stop) } || List ( ... ) : Treecell || ---- || || The LIST routines all work in the same manner || || They take a number of parameters, claim a free storage cell of the || appropriate size, store the parameters in it in a conventional manner, || and return a pointer to the cell as their result || || The first parameter is a Keyword of the AE Tree, and must be in the || range 0 - 255 || || The zero word of the cell holds the Keyword in the bottom 8 bits, and the || cell size in words in the remaining bits. This format defines a Treecell || || The remaining parameters, if any, are stored in order in the other words || of the treecell, and they may be fullword values AND list1(x) = VALOF { LET p = newvec(0) p!0 := x RESULTIS p } AND list2(x,y) = VALOF { LET p = newvec(1) p!0,p!1 := x+#400,y RESULTIS p } AND list3(x,y,z) = VALOF { LET p = newvec(2) p!0,p!1,p!2 := x+#1000,y,z RESULTIS p } AND list4(x,y,z,t) = VALOF { LET p = newvec(3) p!0,p!1,p!2,p!3 := x+#1400,y,z,t RESULTIS p } AND list5(x,y,z,t,u) = VALOF { LET p = newvec(4) p!0,p!1,p!2,p!3,p!4 := x+#2000,y,z,t,u RESULTIS p } AND list6(x,y,z,t,u,v) = VALOF { LET p = newvec(5) p!0,p!1,p!2,p!3,p!4,p!5 := x+#2400,y,z,t,u,v RESULTIS p } || CaeReport ( n : ) || --------- || || This routine is called to produce a syntax error message and take || recovery action || || The error number is given in the 7 low bits of the parameter, and the || recovery action in the next 4 bits || || Error numbers are mapped onto messages by CAEMESSAGE || || The possible recovery actions are || || E.RETURN : no action, take immediate return || E.SKIP : skip to a significalt input Symbol, and take longjump || to the global recovery label || E.STOP : abandon the compilation AND caereport(n) BE { LET action = n/\#7600 reportcount := reportcount + 1 wrchbuf() caemessage(n/\#177) newline() IF reportcount>reportmax \/ action=e.stop DO { writes("Abandoned*N"); stop(3) } IF listing DO FOR i=0 TO chcount+16 DO wrch('*S') macroexpand := TRUE IF action=e.skip DO { UNTIL symb=s.lsect \/ symb=s.rsect \/ symb=s.semicolon \/ symb=s.end DO nextsymb() longjump(rec.p, rec.l) } } || FormTree ( ) : Treecell || -------- || || The main entry point of COSYN || --- ---- ----- ----- -- ----- || || This function sets up the areas needed for syntax analysis, initialises || the environment, and attempts to parse a Coral segment || || The result is a pointer to the Treecell that is the root of the segment, || represented in main store as a data structure called an Applicative || Expression Tree || || Applicative Expression Tree || ----------- ---------- ---- || || The basic tokens || || Symbol || Name || Number || String || || have been defined already || || The Tree is represented as a linked structure of Treecells || || The goal of the Parse is a Segment || || Segment S.seg Name Number Commonlist Block || || NIL || || Commonlist Class Commonspec Commonlist Linenumber || || * Class IN ( S.global, S.absolute ) || || Class Extspec Commonlist Linenumber || || * Class IN ( S.extname ) || || NIL || || Commonspec Namespec || Procspec || Tabspec || || Namespec Type Name Namespec Number || || * Type IN ( T.integer, T.floating, T.barr, T.iarr, T.farr, || T.label, T.switch ) || || NIL || || Procspec Type Name Procspec Nomlist Number || || * Type IN ( T.vproc, T.iproc, T.fproc ) || || NIL || || Nomlist S.nomdef N T1 .. Tn || || * N : number of parameters || * Ti: number of ith parameter || || NIL || || Tabspec Type Name Elementlist Dopevec Number || || * Type IN ( T.table ) || || Elementlist Type Name Elementlist Wordpos || || * Type IN ( T.ifield, T.ffield ) || || Type Name Elementlist Wordpos Totalbits Bitpos || || * Type IN ( T.ufield, T.sfield ) || || NIL || || Wordpos Number || || Totalbits Number || || Bitpos Number || || Dopevec S.Vecdef Q R S || || * Q : total number of elements in array || * R : offset from root (Zero-Zero) to first true element || * S : stride - width of second dimension (zero for 1D arrays) || || Extspec Procext || || Procext Type Name Procext Nomlist String || || NIL || || Block S.let Declist Statlist || || Declist Class Dec Declist Linenumber || || * Class IN ( S.local ) || || Class Dec Presetlist Declist Linenumber || || * Class IN ( S.preset, S.static ) || || Class Dec Base Declist Linenumber || || * Class IN ( S.overlay, S.statov ) || || NIL || || Dec Vardec || Switchdec || Arraydec || Procdec || || Vardec Type Name Vardec || || * Type IN ( T.integer, T.floating ) || || NIL || || Switchdec Type Name || || * Type IN ( T.switch ) || || Arraydec Type Name Arraydec Dopevec || || * Type IN ( T.barr, T.iarr, T.farr ) || || NIL || || Procdec Type Name NIL Nomdef Formallist || || * Type IN ( T.vproc, T.iproc, T.fproc ) || || Formallist Class Formalspec Formallist Linenumber || || * Class IN ( S.formal ) || || NIL || || Formalspec Nameformal || Procformal || Tabformal || || Nameformal Type Name Nameformal || || * Type IN ( T.valint, T.locint, T.valflo, T.locflo, || T.barr, T.iarr, T.farr, T.label, T.switch ) || || NIL || || Procformal Type Name Procformal Nomlist || || * Type IN ( T.vproc, T.iproc, T.fproc ) || || NIL || || Tabformal Type Name Elementlist Dopevec || || * Type IN ( T.table ) || || Presetlist Expr || || NIL || || Base Expr || || Statlist S.seq Stat Statlist || NIL || || Stat Assignment || Labelstat || Proccall || Goto || Answer || Conditional || Forstat || Codestat || || Assignment S.ass Expr Expr || || Labelstat S.colon Labspec Stat || || Labspec S.label Name || || Proccall S.rtap Expr Expr || || Goto S.goto Expr || || Answer S.resultis Expr || || Conditional S.if Expr Expr || S.test Expr Expr Expr || || Forstat S.fora Expr Expr Expr Expr Forbody || v := a STEP b UNTIL c || S.forb Expr NIL Expr Expr Forbody || v := b WHILE c || S.forc Expr Expr Expr Expr Forbody || v := a, b WHILE c || S.ford Expr Expr NIL NIL Forbody || v := a || || Forbody S.forbody Stat NIL NIL || Stat || || Codestat S.code String || || || Expr Diadicop Expr Expr || Monadicop Expr || Primary || || || * Diadicop IN ( S.lshift, S.rshift, S.mask, S.union, S.differ, || S.mult, S.slash, S.div, S.rem, S.plus, S.minus, || S.cond, S.eq, S.ne, S.gr, S.ls, S.ge, S.le, || S.logand, S.logor, S.comma ) || || * Monadicop IN ( S.loc, S.bytebra, S.bra, S.flobra, S.bits, || S.byte, S.int, S.flo, S.plus, S.minus ) || || Primary Name || String || Typednumber || Funccall || Application || || Typednumber Symbol Number String || || * Symbol IN ( S.number, S.numneg, S.flonum, S.floneg) || || Symbol Number NIL || || * Symbol IN ( S.number, S.numneg) || || S.infin Zero || || Funccall S.fnap Expr Expr || || Application S.vecap Expr Expr AND formtree() = VALOF { LET bv = VEC chbufsize // for circular buffer AND wv = VEC 255/bytesperword AND cv = VEC 255 AND nv = VEC namevecsize AND a = nil chbuf,chcount := bv,0 wordv := wv charv := cv namevec := nv FOR i = 0 TO chbufsize DO chbuf!i := 0 rec.p,rec.l := LEVEL,l FOR i=0 TO namevecsize DO namevec!i := nil listing,linecount,oldch := sourcelist,0,'*N' sourcebuff,sourceptr := nil,sourcestream macroexpand,currfp,macrochain,mstacktop := TRUE,nil,nil,treevec nulltag := list4(s.global*256+t.anymode,0,0,0) rch() l: IF nextsymb()=s.end RESULTIS a a := rdsegment() UNLESS symb=s.end DO caereport(91+e.stop) RESULTIS a } || CaeMessage ( n : Number ) || ---------- || || Takes an error number and prints the corresponding error message AND caemessage(n) BE { LET s = VALOF SWITCHON n INTO { CASE 99: RESULTIS "Feature not implemented" CASE 93: RESULTIS "Error in number" CASE 94: RESULTIS "Illegal char" CASE 95: RESULTIS "String too long or contains newline" CASE 96: RESULTIS "CODE insert too long" CASE 97: RESULTIS "number%S" CASE 98: RESULTIS "Program too big" CASE 91: RESULTIS "FINISH%S" CASE 89: RESULTIS "Name%S" CASE 88: RESULTIS "BEGIN%S" CASE 86: RESULTIS "'('%S" CASE 87: RESULTIS "';'%S" CASE 81: RESULTIS "Error in expression" CASE 82: RESULTIS "Error in declaration" CASE 83: RESULTIS "','%S" CASE 84: RESULTIS "']'%S" CASE 85: RESULTIS "')'%S" CASE 76: RESULTIS "DO%S" CASE 72: RESULTIS "'['%S" CASE 73: RESULTIS "UNTIL%S" CASE 90: RESULTIS "Error in label" CASE 92: RESULTIS "Error in command" CASE 74: RESULTIS "THEN%S" CASE 77: RESULTIS "':='%S" CASE 78: RESULTIS "END%S" CASE 79: RESULTIS "WITH%S" CASE 80: RESULTIS "ELSE%S" CASE 71: RESULTIS "':'%S" CASE 70: RESULTIS "bit position outside datum" CASE 69: RESULTIS "array of negative size" CASE 68: RESULTIS "string%S" CASE 67: RESULTIS "error in macro call" CASE 66: RESULTIS "macro not found" CASE 65: RESULTIS "'/'%S" CASE 64: RESULTIS "file not found" CASE 63: RESULTIS "macro arg too long" CASE 62: RESULTIS "wrong number of macro args" CASE 61: RESULTIS "Unknown language word" } writef(s," expected") } . GET "COSYN7.HDR" || Recursive Descent Parser || --------- ------- ------ || || The Coral syntax analyser is structured as an LL(1) recursive descent || parser, with the odd one-symbol lookahead in difficult places || || The object to be recognised is a Coral Segment || || The result of the parse is a data structure in main store || || The parse is performed by hand-coded recogniser routines, each of which || parses one construct big enough to warrant writing a recogniser for || || The routines normally return either NIL or a pointer to the Treecell that || is the root of the parsed construct || || Error recovery is implemented (badly) by two globals || || REC.P : BCPL stack pointer at recovery point || REC.L : BCPL label of recovery point || || After most errors, input is skipped until a suitable symbol is found, || and a longjump taken to the recovey point || || Recovery points are set in some major recognisers, but recovery action || is in CAEREPORT and does not depend on the current recovery point || RdSegment ( ) : Treecell || --------- || || Parse a Coral segment LET rdsegment() = VALOF { LET n,b,g,s = 1,nil,nil,nil rec.p,rec.l := LEVEL,recover s := rname() IF nextis(s.slash) DO n := number() g := rdcommon() ignore(s.semicolon) UNLESS symb=s.end DO { b := rdsect(0) UNLESS head(b)=s.let DO b := list3(s.let,nil,b) } RESULTIS list5(s.seg,s,n,g,b) recover: UNTIL symb=s.end DO nextsymb() RESULTIS nil } || RdSect ( n : Number ) : Treecell || ------ || || Parse a Coral compound statement or block || || The parameter is || || 0 : outermost block of segment || 1 : other block AND rdsect(n) = VALOF { checkfor(s.lsect,88) n := rdblockbody(n) checkfor(s.rsect,78) RESULTIS n } || RNameList ( t : Type ) : Treecell || --------- || || Parse a list of identifiers and construct a list of cells that || declare them as variables of type T AND rnamelist(t) = list3(t,rname(), nextis(s.comma)->rnamelist(t),nil) || Number ( ) : Number || ------ || || Parse an integer constant and return its binary value || || This routine is called for things like BITS parameters and array || bounds, where the numerical value is needed in the front end || || It may not work if the host machine has a smaller word than the target || || The function will absorb a monadic minus into a following number, but || will perform no other arithmetic AND number() = VALOF { LET a,b = 0,FALSE ignore(s.plus) b := nextis(s.minus) a := decval IF b DO a := -a checkfor(s.number,97) RESULTIS a } || RName ( ) : Treecell || ----- || || Parse a Coral identifier and return a pointer to its entry in the || name dictionary AND rname() = VALOF { LET a = wordnode checkfor(s.name,89) RESULTIS a } || Ignore ( item : Symbol ) : Bool || ------ || || Nextis ( item : Symbol ) : Bool || ------ || || These are two names denoting the same routine || || It tests whether the current Symbol is ITEM || If so, consumes it and returns TRUE || If not, returns FALSE || || IGNORE() should be used if it does not matter whether the symbol was there || NEXTIS() should be used if it does matter AND ignore(item) = VALOF // also NextIs { UNLESS symb=item RESULTIS FALSE nextsymb() RESULTIS TRUE } || CheckFor ( item : Symbol; n : Error ) || -------- || || Checks that the current symbol is ITEM || If so, consumes it || If not, signals error N AND checkfor(item, n) BE UNLESS nextis(item) DO caereport(n+e.skip) || LookFor ( item : Symbol; n : Error ) || ------- || || Checks that the next symbol is ITEM || If not, signals error N || || In either event, the parser steps one symbol first AND lookfor(item,n) BE UNLESS nextsymb()=item DO caereport(n+e.skip) || RBExp ( ) : Treecell || ----- || || Parses a 'basic expression', which is roughly a Coral 'primary' || and returns a pointer to its root AND rbexp() = VALOF { LET a,op = nil,symb IF op=s.semicolon RESULTIS nil SWITCHON op INTO { CASE s.name: CASE s.string: a := wordnode ENDCASE CASE s.flonum: CASE s.number: a := list3(op,decval,wordnode) ENDCASE CASE s.infin: a := list2(op,0) // pseudointeger value is 0 for S.INFIN ENDCASE CASE s.cond: a := rnexp(0) checkfor(s.then,74) op := rexp(0) checkfor(s.else,80) RESULTIS list4(s.cond,a,op,rexp(32)) CASE s.lparen: a := rnexp(0) checkfor(s.rparen,85) RESULTIS a CASE s.loc: a := rnexp(40) IF head(a) = s.bra RESULTIS h2!a RESULTIS list2(s.loc,a) CASE s.byte: CASE s.int: CASE s.flo: UNLESS nextsymb()=s.bra RESULTIS list2(op,rexp(40)) op := op=s.byte -> s.bytebra, op=s.flo -> s.flobra, s.bra CASE s.bra: CASE s.bytebra: CASE s.flobra: a := rnexp(0) checkfor(s.ket,84) IF head(a)=s.loc RESULTIS h2!a RESULTIS list2(op,a) CASE s.bits: nextsymb() checkfor(s.bra,72) a := number() checkfor(s.comma,81) op := number() checkfor(s.ket,84) IF op<0 \/ a+op>intsize*8 DO caereport(70+e.return) RESULTIS list4(s.bits,a,op,rexp(40)) CASE s.plus: CASE s.minus: a := rnexp(34) IF op=s.plus RESULTIS a op := head(a) TEST op=s.number \/ op=s.flonum THEN h1!a,h2!a :=op+(s.numneg-s.number),-(h2!a) OR UNLESS op=s.infin DO a := list2(s.neg,a) RESULTIS a DEFAULT: caereport(81+e.skip) } nextsymb() RESULTIS a } || RExp ( n : Number ) : Treecell || ---- || || Parses an expression and returns a pointer to its root || || The parse is done by simple operator precedence, with the || input parameter giving the initial precedence || || The leftmost primary is parsed, and the following symbol || inspected. If this is not an operator, or has lower precedence || than the parameter, the parse is finished. Otherwise, the || function is called recursively, with the R priority of the || operator, to obtain the right operand || || The following priorities are used || || 40 : primary || 39 : shifts || 38 : MASK || 37 : UNION || 36 : DIFFER || 35 : multiplicative ( * / % MOD ) || 34 : additive ( + - ) || 32 : conditional || 30 : comparators ( = <> > <= < >= ) || 23 : AND || 22 : OR || 12 : list ( , ) || 0 : expression AND rexp(n) = VALOF { LET a = rbexp() AND p,b = 0,nil { LET op = symb SWITCHON op INTO { DEFAULT: RESULTIS a CASE s.lparen: UNLESS nextsymb()=s.rparen DO b := rexp(0) checkfor(s.rparen,85) UNLESS head(a) = s.name DO caereport(81+e.return) a := list3(s.fnap,a,b) LOOP CASE s.bra: b := rnexp(0) checkfor(s.ket,84) a := list3(s.vecap,a,b) LOOP CASE s.lshift: CASE s.rshift: p := 39; ENDCASE CASE s.mask: p := 38; ENDCASE CASE s.union: p := 37; ENDCASE CASE s.differ: p := 36; ENDCASE CASE s.rem: CASE s.mult: CASE s.div: CASE s.slash: p := 35; ENDCASE CASE s.plus: CASE s.minus: p := 34; ENDCASE CASE s.eq: CASE s.ne: CASE s.gr: CASE s.le: CASE s.ls: CASE s.ge: p := 30; ENDCASE CASE s.logand: p := 23; ENDCASE CASE s.logor: p := 22; ENDCASE CASE s.comma: p := 12; ENDCASE } IF n>=p RESULTIS a a := list3(op,a,rnexp(op=s.comma->p-1,p)) } REPEAT } || RNExp ( n : Number ) : Treecell || ----- || || Parse an expression as for REXP(), but first consume the current symbol AND rnexp(n) = VALOF { nextsymb(); RESULTIS rexp(n) } . GET "COSYN7.HDR" || RdCommon ( ) : Treecell || -------- || || Parse the Coral Communcator declarations || || This function recognises COMMON, ABSOLUTE and EXTERNAL, and will parse || any number of such declarations one after the other, building a || linked tree equivalent in store and returning the root pointer LET rdcommon() = VALOF { LET a,b = nil,symb UNLESS b=s.global \/ b=s.absolute \/ b=s.extname RESULTIS nil nextsymb() checkfor(s.lparen,86) a := rfplist(b) checkfor(s.rparen,85) ignore(s.semicolon) b := a UNTIL h3!b=nil DO b := h3!b h3!b := rdcommon() RESULTIS a } || RNVList ( t : Type ) : Treecell || ------- || || Parse a sequence of name-value pairs and construct a list that || declares them to be variables of type T || || The value required must be a Number AND rnvlist(t) = VALOF { LET b = nil { LET a = rname() checkfor(s.slash,65) b := list4(t,a,b,number()) } REPEATWHILE nextis(s.comma) RESULTIS b } || RFPList ( c : Class ) : Treecell || ------- || || Parse a list of Coral specifications || || A specification is found in both Communicators and Procedure formals, || and these two cases are distinguished by the parameter || || S.FORMAL : formals || S.GLOBAL : COMMON communicator || S.ABSOLUTE : ABSOLUTE ditto || S.EXTNAME : EXTERNAL ditto AND rfplist(c) = VALOF { LET a,t,ln = nil,t.void,linecount ignore(s.semicolon) IF symb=s.rparen RESULTIS nil t := rdtype() IF t=t.void DO caereport(82+e.skip) TEST t.vproc<=t<=t.fproc THEN { LET k = LV a { LET b = (c=s.formal->list4,list5)(t,rname(),nil,nil,0) UNLESS c=s.formal DO { checkfor(s.slash,65) TEST c=s.extname THEN { LET w = wordnode checkfor(s.string,68) h5!b := w } OR h5!b := number() } IF nextis(s.lparen) DO h4!b := rdnomlist() RV k := b k := b + h3 } REPEATWHILE nextis(s.comma) } OR { IF c=s.extname \/ c=s.absolute /\ ~(t=t.integer\/t=t.floating\/t=t.label) DO caereport(99+e.skip) a := t=t.table -> rdtabspec(c), c=s.formal -> rnamelist(t), rnvlist(t) } RESULTIS list4(c,a,rfplist(c),ln) } || RdType ( ) : Type || ------ || || Attempts to parse the Type part of a Coral declaration || || If successful, returns the internal code of the type || Otherwise, returns T.VOID || || Note that this is an LR(1) operation since we must distinguish eg || || INTEGER i || INTEGER ARRAY i || INTEGER [ || || and in principle || || INTEGER ( || || though that must be illegal in this context AND rdtype() = VALOF { LET t,sw = symb,0 SWITCHON symb INTO { DEFAULT: RESULTIS t.void CASE s.val: sw := sw+1 CASE s.loc: t := t.locint+sw IF nextsymb()=s.int ENDCASE checkfor(s.flo,82) RESULTIS t+2 CASE s.flo: sw := sw+1 CASE s.int: t := t.iarr+sw IF nextsymb()=s.array ENDCASE IF symb=s.proc DO { t := t.iproc+sw; ENDCASE } IF symb=s.bra DO { UNLESS sw=0 DO symb := s.flobra; RESULTIS t.void } RESULTIS t.integer+sw CASE s.unsigned: t := t.ufield; ENDCASE CASE s.byte: IF nextsymb()=s.bra DO { symb := s.bytebra; RESULTIS t.void } checkfor(s.array,82) RESULTIS t.barr CASE s.table: t := t.table; ENDCASE CASE s.proc: t := t.vproc; ENDCASE CASE s.switch: t := t.switch; ENDCASE CASE s.label: t := t.label CASE s.overlay: } nextsymb() RESULTIS t } || RdNomList ( ) : Treecell || --------- || || Parse a procedure parameter list at the second level of nesting || || Such a list consists of a sequence of types separated by commas || || The result is a special NOMDEF cell not in standard Treecell format AND rdnomlist() = VALOF { LET v = VEC 64 LET n,a = 0,nil { n,a,v!n := n+1,rdtype(),a IF a=t.void DO caereport(82+e.skip) } REPEATWHILE nextis(s.comma) checkfor(s.rparen,85) a := newvec(n+1) a!0,a!1 := s.nomdef,n FOR i=1 TO n DO a!(i+1) := v!i RESULTIS a } || RDecList ( n : Number ) : Treecell || -------- || || Parse a list of Coral declarations || || The parameter indicates the block level: || || n = 0 : outer block || n = 1 : inner block || || The default storage class is Static for the outer block and || Local for inner blocks || || The function will parse any number of declarations one after || another, but it does not require any declaration at all to be || found, in which case it will return NIL AND rdeclist(n) = VALOF { LET st,ps,ol,ro,ln = FALSE,TRUE,FALSE,FALSE,linecount LET a,b,t = nil,nil,rdtype() IF t=t.void RESULTIS nil IF n<=0 DO st := TRUE IF t=s.overlay DO { a := rexp(0) checkfor(s.with,79) t := rdtype() IF t=t.void DO caereport(82+e.skip) ol,ps := TRUE,FALSE } SWITCHON t INTO { CASE t.floating: CASE t.integer: b := rnamelist(t); ENDCASE CASE t.table: b := rdtabspec(s.local); ENDCASE CASE t.iarr: CASE t.barr: CASE t.farr: { LET c = LV b LET d = c { h1!c, c := list4(t,rname(),nil,nil), h1!c + h3 REPEATWHILE nextis(s.comma) checkfor(s.bra,72) { LET q,r,s,t = 0,number(),0,0 checkfor(s.colon,71) q := number() UNLESS q>=r DO caereport(69+e.skip) q := q-(r-1) IF nextis(s.comma) DO { t := number() checkfor(s.colon,71) s := number() UNLESS s>=t DO caereport(69+e.return) s := s-(t-1) } checkfor(s.ket,84) UNLESS s=0 DO q,r := q*s, r*s+t q := list4(s.vecdef,q,r,s) h4!(h1!d),d := q, h1!d +h3 REPEATUNTIL h1!d = nil } } REPEATWHILE nextis(s.comma) ENDCASE } CASE t.switch: IF ol DO caereport(89+e.skip) b := list2(t.switch,rname()) st,ps := TRUE,FALSE checkfor(s.ass,77) a := rnamelist(t.label) ENDCASE DEFAULT: caereport(82+e.skip) CASE t.iproc: CASE t.vproc: CASE t.fproc: IF ol DO caereport(89+e.skip) b := list5(t, rname(),nil,nil,nil) ps,st := FALSE,TRUE IF nextis(s.lparen) DO { LET v = VEC 64 LET n,k = 0,rfplist(s.formal) h5!b := k checkfor(s.rparen,85) UNTIL k=nil DO { LET l = h2!k LET t = head(l) UNTIL l=nil DO { n,v!n,l := n+1,t,h3!l; IF t=t.table BREAK } k := h3!k } k := newvec(n+1) k!0,k!1 := s.nomdef,n FOR i=1 TO n DO k!(i+1) := v!i h4!b := k } checkfor(s.semicolon,87) a := rcom() } IF ps /\ symb=s.eq DO ro,symb := TRUE,s.ass IF ps /\ nextis(s.ass) DO { LET c = LV a st := TRUE UNTIL symb=s.semicolon \/ symb=s.rsect DO { WHILE symb=s.lparen DO nextsymb() t := symb=s.comma \/ symb=s.rparen -> list2(s.number,maxint), rexp(12) h1!c := list3(s.comma,t,nil); c := h1!c + h3 t := head(t) UNLESS t=s.mult \/ s.number<=t<=s.infin DO caereport(82+e.return) WHILE symb=s.rparen DO nextsymb() ignore(s.comma) } } UNLESS symb=s.rsect DO checkfor(s.semicolon,87) { LET p = rdeclist(n) IF st \/ ol RESULTIS list5(ol->st->s.statov,s.overlay,ro->s.preset,s.static,b,a,p,ln) RESULTIS list4(s.local,b,p,ln) } } || RdBlockbody ( n : Number ) : Treecell || ----------- || || Parse the body of a Coral block or compound statement || || The level of nesting is indicated by the parameter: || || n = 0 : outer block || n = 1 : inner block || || The recogniser will handle the four cases || || empty BEGIN END || declarations only || statements only || declarations; statements || || Note that an 'empty' blockbody is syntactically a compound || statement containing only the dummy statement, but is in || this parser returned as NIL || || The recogniser contains an error recovery point. The present || version (V6.00) is very bad, since an error within a procedure || body causes all subsequent declarations to be faulted as || seemingly occurring after statements AND rdblockbody(n) = VALOF { LET p,l = rec.p,rec.l LET a,b,ln = nil,nil,0 AND sw = FALSE LET c = LV b rec.p,rec.l := LEVEL,recover ll: a := rdeclist(n) UNLESS a=nil DO { RV c := list3(s.let,a,nil); c := RV c +h3 } UNLESS symb=s.rsect DO { ln := linecount a := rcom() TEST a=nil THEN IF sw DO caereport(92+e.skip) OR { sw := FALSE RV c := list4(s.seq,a,nil,ln) c := RV c + h3 } IF symb=s.rsect BREAK UNLESS nextis(s.semicolon) DO { caereport(87+e.return); sw := TRUE } } REPEAT recover: IF symb=s.semicolon \/ symb=s.lsect DO { nextsymb(); GOTO ll } rec.p,rec.l := p,l RESULTIS b } . // Commands GET "COSYN7.HDR" || RdTabSpec ( cl : Class) : Treecell || --------- || || Read a specification or declaration of a Coral table || || The parameter gives the storage class of the table || || S.GLOBAL : Common || S.ABSOLUTE : Absolute || S.FORMAL : Formal parameter || S.LOCAL : Other || || Note that class Extname cannot occur, since only procedures may be || declared External || || The first three imply a table 'specification', and the last a || 'declaration', but the form is virtually identical || || The routine does not attempt to read any table preset list, || which can only occur in the last case and which is dealt with || in the calling routine LET rdtabspec(cl) = VALOF { LET b,c,d,f = 0,0,0,list4 LET a = rname() IF cl=s.global \/ cl=s.absolute DO { checkfor(s.slash,82) d := number() f := list5 } checkfor(s.bra,72) b := number() checkfor(s.comma,83) c := number()*b checkfor(s.ket,84) IF c<=0 DO caereport(69+e.return) b := list4(s.vecdef,c,nil,b) a := f(t.table,a,nil,b,d) b := nil checkfor(s.bra,72) WHILE symb=s.name DO { LET n = rname() LET t = rdtype() LET op = t.ifield SWITCHON t INTO { CASE t.floating: op := t.ffield CASE t.integer: b := list4(op,n,b,number()) ENDCASE DEFAULT: caereport(82+e.skip) CASE t.void: t := t.sfield CASE t.ufield: checkfor(s.lparen,86) d := number() checkfor(s.rparen,85) c := number() checkfor(s.comma,83) f := number() IF d+f>intsize*8 DO caereport(70+e.return) b := list6(t,n,b,c,d,f) } ignore(s.semicolon) } h3!a := b checkfor(s.ket,84) RESULTIS a } || RCom ( ) : Treecell || ---- || || Parse a Coral commmand || || This is a strict LL(1) recogniser || || It is rather more general than Coral syntax allows, since it || accepts for example an expression on the LHS of an assignment || or after a GOTO. Some of this generality is removed by the || subsequent semantic checks, and some is genuine AND rcom() = VALOF { LET a,b,op = nil,nil,symb SWITCHON op INTO { || The general case || || An expression must be read, and then the next symbol || The possible cases are || || Assignment Expr := Expr || Label setting Name : Stat || Routine call CASE s.name: CASE s.byte: CASE s.int: CASE s.flo: CASE s.bra: CASE s.lparen: CASE s.bits: CASE s.bytebra: CASE s.flobra: || These are the only symbols that can start an expression a := rexp(0) IF symb=s.ass RESULTIS list3(s.ass,a,rnexp(0)) b := head(a) IF nextis(s.colon) DO { UNLESS b=s.name DO caereport(90+e.skip) RESULTIS list3(s.colon, list2(s.label,a), rcom()) } IF b=s.fnap DO { h1!a := s.rtap+#1000 RESULTIS a } IF b=s.name RESULTIS list3(s.rtap,a,nil) caereport(92+e.skip) || GOTO and ANSWER statements CASE s.goto: CASE s.resultis: RESULTIS jumplist(op,rnexp(0)) || Conditional || || This is converted into an IF node if no ELSE part is present || and a TEST node if an ELSE part is present CASE s.cond: a := rnexp(0) checkfor(s.then,74) b := rcom() UNLESS nextis(s.else) RESULTIS list3(s.if,a,b) RESULTIS list4(s.test,a,b,rcom() ) || FOR statement || || The general FOR statement is broken down into a list of || primitive statements, connected by SEQ nodes. The FOR || primitives are those given in the Tree syntax: || || FORA : FOR v:=a STEP b UNTIL c || FORB : FOR v:=b WHILE c || FORC : FOR v:=a, b WHILE c || FORD : FOR v:=a || || The list of statements share the for body node, the Stat || after the DO symbol. This body may be either replicated || during translation or converted into a Forbody, which is || generated once and referenced indirectly || || the current algorithm is || || Only one FOR primitive: do not replicate || For body comprises a simple statement: replicate || Otherwise: convert into a Forbody || || A 'simple' statement is currently || || assignment || routine call || IF .. THEN assignment || IF .. THEN routine call || || The FOR body is always converted into a block, by prefacing || it with a LET node if necessary CASE s.for: { LET v = rnexp(0) AND f,ln = nil,linecount LET g = LV f checkfor(s.ass,77) op := s.ford { a := rexp(12) ll: TEST symb=s.step THEN { b := rnexp(12) checkfor(s.until,73) op := s.fora } OR TEST nextis(s.while) THEN op,b,a := s.forb,a,nil OR TEST symb=s.comma THEN { b := rnexp(12) op := nextis(s.while) -> s.forc,s.ford } OR UNLESS op=s.ford BREAK !g := list4(s.seq,list6(op,v,a,b,op=s.ford->nil,rexp(12),nil),nil,ln) g := !g + h3 IF op=s.ford /\ b~=nil DO { a := b; b := nil; GOTO ll } } REPEATWHILE nextis(s.comma) checkfor(s.do,76) a := rcom() { LET ha = head(a) UNLESS ha=s.let DO a := list3(s.let,nil,a) UNLESS h3!f=nil \/ ha=nil \/ ha=s.ass \/ ha=s.rtap \/ ha=s.if /\ (head(h3!a)=s.ass \/ head(h3!a)=s.rtap) DO a := list4(s.forbody,a,0,0) } g := f UNTIL g=nil DO h6!(h2!g),g := a,h3!g RESULTIS f } || Code statement || || A code statement is enclosed in CODE BEGIN .. END || the code must be further enclosed in either fractur brackets <..> || or braces {..} || || Within the code, sequences in braces {..} are skipped as comment, || sequences within brackets [..] are interpreted as Coral objects, || and semicolon ; is equivalent to newline || || The code sequence is still stored as a string, so is limited || to 255 characters CASE s.code: lookfor(s.lsect,88) UNTIL ch='{' \/ ch='<' DO rch() { LET v = VEC 255 AND term = '}' LET i = 0 IF ch='<' DO term := '>' { IF rch()='{' DO skipto('}') IF ch=codetripchar DO { LET trip = #200 IF rch()='^' DO { rch(); trip := #201 } op := nextsymb() TEST s.name<=op<=s.string THEN IF codetripchar='[' DO lookfor(s.ket,84) ELSE caereport(89+e.return) IF op=s.number \/ op=s.numneg DO wordnode := list2(s.number,decval) wordnode := wordnode - treevec v!(i+1),v!(i+2),v!(i+3),i := trip,wordnode>>8,wordnode/\#377,i+3 } IF ch=';' DO ch := '*N' IF ch=term BREAK IF i>=255 DO { skipto(term); caereport(96+e.skip) } i,v!i := i+1,ch } REPEAT rch() v!0 := i a := newvec(1+i/bytesperword) packstring(v,a+1) } a!0 := s.code nextsymb() checkfor(s.rsect,78) DEFAULT: RESULTIS a CASE s.lsect: RESULTIS rdsect(1) } } || JumpList ( op : Symbol; a : Treecell ) : Treecell || -------- || || Generate a tree fragment representing a Goto or Answer || || These operations are followed by an expression. However, || if the expression is conditional, it is better to float the || jump into each branch of the expression || || This is done by JumpList, which returns the revised fragment AND jumplist(op,a) = VALOF { UNLESS head(a)=s.cond RESULTIS list2(op,a) RESULTIS list4(s.test,h2!a, jumplist(op,h3!a), jumplist(op,h4!a)) } .