SECTION "Lex"

GET "b.Header"

STATIC
$( // Version of  28 Feb 86 13:04:59
   dummy = VersionMark;
   version = 1*256+2
$)

/* 1.2	28 Feb 86 13:05:10
     ccstack initialised to zero (so unmatching tags don't cause
     compiler collapse
*/

LET initialise.lex() BE
$( ccstack := 0;
   DeclSysWords()
   RCh()
$)

AND NextSymb() BE
$( LET BasicSymb() BE
   $( nlPending := FALSE

      $( SWITCHON ch INTO
	 $( CASE '*N': nlPending := TRUE
	    CASE '*T':
	    CASE '*S':
	      RCh() REPEATWHILE ch='*S'
	      LOOP

	    CASE '0': CASE '1': CASE '2': CASE '3':
	    CASE '4': CASE '5': CASE '6': CASE '7':
	    CASE '8': CASE '9':
	      symb := s.number
	      ReadNumber(10);
	      IF ch='.' | ch='E' | ch='e' THEN ReadFloat();
	      RETURN

	    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':
	    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':
	      $( LET c=ch

		 RCh()
		 RdTag(c)
		 symb := LookUpWord()

		 IF symb=s.get THEN
		 $( PerformGet()
		    LOOP
		 $)
		 RETURN
	      $)

	    CASE '{': CASE '}':
	      symb := ch='{' -> s.lsect, s.rsect;
	      RCh();
	      RdTag('$');
	      LookUpWord();
	      RETURN

	    CASE '$':
	      multichar("()<>$", s.lsect,s.rsect, 1,2,
			s.tagname, 0)

	      IF symb=s.lsect | symb=s.rsect THEN
	      $( RdTag('$')
		 LookUpWord()
		 RETURN $)

	      IF extension.level>=3 & symb~=0 THEN
	      $( LET cch = CapitalCh(ch)
		 LET c = ch
		 IF ~['A'<=cch<='Z' | '0'<=cch<='9']
		    THEN SynReport(2)

		 RCh()
		 RdTag(c)
		 tagptr := LookUpTag(wordv)

		 IF symb~=s.tagname THEN
		   //
		   // $<tag or $>tag
		   //
		 $( LET inverse = FALSE
		    IF ch='*'' THEN
		    $( RCh()
		       inverse := TRUE $);
		    conditional.compilation(symb=1, tagptr, inverse)
		    LOOP $)
		 RETURN
	      $)
	      SynReport(91)
	      ENDCASE

	    CASE '[':
	    CASE '(': symb := s.lparen; BREAK
	    CASE ']':
	    CASE ')': symb := s.rparen; BREAK

	    CASE '#':
	      $( LET radix = 8
		 RCh()
		 IF ~['0'<=ch<='7'] THEN
		 $( SWITCHON CapitalCh(ch) INTO

		    $( DEFAULT:
			  BasicSymb();
			  SWITCHON symb INTO
			  $( CASE s.plus:CASE s.minus:CASE s.mult:CASE s.div:
			     CASE s.abs:
			     CASE s.ls:CASE s.gr:CASE s.le:CASE s.ge:
			     CASE s.eq:CASE s.ne:
				symb := symb+s.fadd;
				RETURN

			     DEFAULT:
				SynReport(33)
			  $)

		       CASE 'B':radix := 2;ENDCASE
		       CASE 'O':radix := 8;ENDCASE
		       CASE 'X':radix := 16
		    $)
		    RCh() $)
		 ReadNumber(radix)
		 symb := s.number
		 RETURN
	      $)

	    CASE '?': symb := s.query;	   BREAK
	    CASE '+': symb := s.plus;	   BREAK
	    CASE ',': symb := s.comma;	   BREAK
	    CASE ';': symb := s.semicolon; BREAK
	    CASE '@': symb := s.lv;	   BREAK
	    CASE '&': symb := s.logand;    BREAK
	    CASE '=': symb := s.eq;	   BREAK
	    CASE '!': symb := s.vecap;	   BREAK
	    CASE '**':symb := s.mult;	   BREAK

	    CASE '%':
	       IF extension.level<2 THEN
	       $( ch := 0
		  LOOP $)
	       symb := s.byteap
	       BREAK

	    CASE '|':
	      IF extension.level<1 THEN
	      $( symb := s.logor
		 BREAK $)

	      multichar("|", 0, s.logor)
	      IF symb~=0 THEN RETURN

	cmnt: UNTIL ch='*N' | ch='*P' | ch=EndStreamCh	DO
		RCh()
	      LOOP

	    CASE '/':
	      multichar("\/**", s.logand, 0, -1, s.div)
	      IF symb>0 THEN RETURN
	      IF symb=0 THEN GOTO cmnt

	      $( IF ch='**' THEN
		 $( RCh()
		    IF ch='/' THEN BREAK
		    LOOP $)
		 IF ch=EndStreamCh THEN SynReport(63);
		 RCh()
	      $) REPEAT
	      RCh()
	      LOOP

	    CASE '~':
	      multichar("=", s.ne, s.not)
	      RETURN

	    CASE '\':
	      multichar("/=", s.logor, s.ne, s.not)
	      RETURN

	    CASE '<':
	      multichar("=<", s.le, s.lshift, s.ls)
	      RETURN

	    CASE '>':
	      multichar("=>", s.ge, s.rshift, s.gr)
	      RETURN

	    CASE '-':
	      multichar(">", s.cond, s.minus)
	      RETURN

	    CASE ':':
	      multichar("=", s.ass, s.colon)
	      RETURN

	    CASE '"':
	      $( LET i = 0
		 LET sch = ?

		 WHILE RdStrCh('"', @sch) DO
		 $( IF i=255 THEN SynReport(34)
		    i := i+1
		    wordv%i := sch $)
		 wordv%0 := i
		 symb := s.string
		 BREAK
	      $)

	    CASE '*'':
	      $( LET ok = RdStrCh('*'', @decval)
		 symb := s.number;
		 IF ok THEN
		 $( RCh()
		    ok := ch='*'' $)
		 IF ~ok THEN SynReport(34)
		 BREAK
	      $)

	    DEFAULT:
	      IF ch~=EndStreamCh THEN
	      $( ch := '*S'
		 SynReport(94) $)

	    CASE '.':
	      IF getp=0 THEN
	      $( symb := s.end
		 BREAK $)
	      close(sourceStream)

	      getp := getp-3
	      sourceStream := getv!getp
	      lineCount := getv!(getp+1)
	      ch := getv!(getp+2)

	      SelectInput(sourceStream)
	      LOOP
	 $)
      $) REPEAT
      RCh()
   $)

   BasicSymb()

   // Check for tag setting directive.	This is of the
   // form:
   //	    $$tag    or   $$tag := expn
   //
   // A $$tag symbol is of type 's.tagname'.
   //
   // A loop is used to get cases like $$tag $$tag2 := ..  right.

   WHILE symb=s.tagname DO
   $( LET tag = tagptr
      LET value = FALSE
      LET op = s.logor

      BasicSymb()

      // If the $$tag was not followed by :=, simply
      // invert the value of the tag and go round again.

      IF symb~=s.ass THEN
      $( tag.value!tag := ~tag.value!tag
	 LOOP $)

      $( LET inverse = FALSE
	 LET sval =  ?

	 BasicSymb()

	 IF symb=s.not THEN
	 $( inverse := TRUE
	    BasicSymb() $)

	 SWITCHON symb INTO
	 $( CASE s.tagname:
	      sval := tag.value!tagptr
	      ENDCASE

	    CASE s.true:
	      sval := TRUE
	      ENDCASE

	    CASE s.false:
	      sval := FALSE
	      ENDCASE

	    DEFAULT:
	      SynReport(1)
	      ENDCASE
	 $)

	 // Combine the value with the expression so far
	 // and check for an operator.

	 IF inverse THEN sval := ~sval

	 TEST op=s.logor
	    THEN value := value | sval
	    ELSE value := value & sval

	 BasicSymb()
	 op := symb
      $) REPEATWHILE op=s.logor | op=s.logand

      tag.value!tag := value
   $)

   // Symbol is not $$tag: check for a compound assignment
   // (note that op:= is an extension).

   IF extension.level>=3 THEN SWITCHON symb INTO
   $( CASE s.mult:   CASE s.div:  CASE s.rem:
      CASE s.plus:   CASE s.minus:
      CASE s.fmult:  CASE s.fdiv:
      CASE s.fplus:  CASE s.fminus:
      CASE s.logand: CASE s.logor:
      CASE s.eqv:    CASE s.neqv:
      CASE s.lshift: CASE s.rshift:
	//
	// Check for := following operator.
	//
	IF ch=':' THEN
	$( LET ch = RdCh(); UnRdCh()

	   IF ch='=' THEN
	   $( RCh(); RCh()
	      operator := symb
	      symb := s.opab $) $)
   $)
$)

AND multichar(chars, a, b, c, d, e, f, g, h) BE
$( LET t = @chars
   LET i, lim = 1, chars%0
   RCh()

   WHILE i<=lim DO
   $( IF ch=chars%i THEN
      $( RCh()
	 BREAK $)
      i := i+1 $)
   symb := t!i
$)

AND LookUpWord() = VALOF
$( LET hashval = VALOF
   $( LET res = wordv%0
      FOR i = 1 TO res DO
	res := (res*13 + CapitalCh(wordv%i)) & #X7FFF

      RESULTIS res REM nametablesize
   $)

   LET CString(s1, s2) = VALOF
   $( LET len = s1%0
      IF len~=s2%0 THEN RESULTIS FALSE

      FOR j = 1 TO len DO
	TEST equateCases
	  THEN IF CapitalCh(s1%j)~=CapitalCh(s2%j)
	    THEN RESULTIS FALSE
	  ELSE IF s1%j~=s2%j
	    THEN RESULTIS FALSE

      RESULTIS TRUE
   $)
   LET i = 0
   wordNode := nametable!hashval

   WHILE wordNode~=0 & ~CString(wordNode+2, wordv) DO
     wordNode := h2!wordNode

   IF wordNode=0 THEN
   $( LET size = wordv%0 / BytesPerWord

      wordNode := getblk(size+3)
      wordNode!0 := s.name
      wordNode!1 := nametable!hashval

      FOR i = 0 TO size DO wordNode!(i+2) := wordv!i
      nametable!hashval := wordNode $)
   RESULTIS h1!wordNode
$)

AND conditional.compilation(startcond, tagptr, inverse) BE
  //
  // Called after $<tag or $>tag has been recognised.
  //
  //  startcond 	true for $<, false for $>
  //  tagptr		pointer to tag object
  //  inverse		true if tag was followed by '.
  //
   TEST startcond THEN
      TEST tag.value!tagptr~=inverse THEN $(
	 // Do not skip: add new item to cc stack.
	 LET s = get.ccstack.item()
	 cc.link!s := ccstack
	 ccstack := s
	 cc.inverse!s := inverse
	 cc.tagptr!s := tagptr $)

      ELSE $( // Skip until a matching $>tag is found.	The quotes must match
	 LET inv2 = FALSE
	 $( IF ch=EndStreamCh THEN SynReport(3)

	    IF ch='$' THEN $(
	       RCh()
	       IF ch='>' THEN $(
		  LET c, d = ?, ?
		  RCh()
		  d := ch
		  c := CapitalCh(ch)

		  IF 'A'<=c<='Z' | '0'<=c<='9' THEN $(
		     RCh()
		     RdTag(d)
		     IF CompString(wordv, tag.name+tagptr)=0 THEN BREAK $)
		  LOOP $)
	       LOOP $)
	    RCh()
	 $) REPEAT

	      // Skip complete: check that quotes match
	 IF ch='*'' THEN $(
	    inv2 := TRUE
	    RCh() $)

	 IF inv2~=inverse THEN SynReport(4) $)

   ELSE $( // $>tag:  check that it matches the last $<tag.
      IF ccstack~=0 THEN
	 TEST tagptr=cc.tagptr!ccstack THEN $(
	   // Proper match: unstack item and check quotes match.
	    LET inv1 = cc.inverse!ccstack
	    LET next = cc.link!ccstack
	    cc.link!ccstack := free.ccstack.chain
	    free.ccstack.chain := ccstack
	    ccstack := next

	    IF inv1~=inverse THEN SynReport(4)
	    RETURN $)
	 ELSE $( // Tags do not match: if the current tag occurs
		 // below on the stack, remove those items above
		 // it.
	    LET m = ccstack

	    WHILE m~=0 & cc.tagptr!m~=tagptr DO
		  m := cc.link!m

	    IF m~=0 THEN $(
	       LET next = cc.link!m
	       cc.link!m := free.ccstack.chain
	       free.ccstack.chain := ccstack
	       ccstack := next $) $)

      SynReport(5) $)

AND get.ccstack.item() = VALOF
$( LET c = free.ccstack.chain
   IF c=0 THEN RESULTIS GetBlk(cc.size)

   free.ccstack.chain := cc.link!c
   RESULTIS c
$)

AND DeclSysWords() BE
$( LET bad = TABLE s.bad, s.bad

   symb :=
     TABLE
       s.and,s.abs,
       s.be,s.break,s.by,
       s.case,
       s.do,s.default,
       s.eq,s.eqv,s.or,s.endcase,
       s.false,s.for,s.finish,
       s.goto,s.ge,s.gr,s.global,s.get,
       s.if,s.into,
       s.let,s.lv,s.le,s.ls,s.logor,
       s.logand,s.loop,s.lshift,
       s.manifest,
       s.ne,s.not,s.neqv,s.needs,
       s.or,
       s.resultis,s.return,s.rem,s.rshift,s.rv,
       s.repeat,s.repeatwhile,s.repeatuntil,
       s.switchon,s.static,s.section,
       s.to,s.test,s.true,s.do,s.table,
       s.until,s.unless,
       s.vec,s.valof,
       s.while,
       0

   D( "AND ABS *
     *BE BREAK BY *
     *CASE *
     *DO DEFAULT *
     *EQ EQV ELSE ENDCASE *
     *FALSE FOR FINISH *
     *GOTO GE GR GLOBAL GET *
     *IF INTO *
     *LET LV LE LS LOGOR LOGAND LOOP LSHIFT")

   D("MANIFEST *
     *NE NOT NEQV NEEDS *
     *OR *
     *RESULTIS RETURN REM RSHIFT RV *
     *REPEAT REPEATWHILE REPEATUNTIL *
     *SWITCHON STATIC SECTION *
     *TO TEST TRUE THEN TABLE *
     *UNTIL UNLESS *
     *VEC VALOF *
     *WHILE *
     *$")

   nulltag := wordNode

   IF lispExtensions THEN {
      symb := (TABLE s.nil, s.car, s.cdr, s.vcar, s.vcdr,
		     s.lle,s.lge,s.lgr,s.lls);
      D("NIL CAR CDR VCAR VCDR LLE LGE LGR LLS") }

   // If the extension level is suitable, declare the
   // symbols SLCT and OF appropriately.  Otherwise,
   // declare them as 'bad', so that they are still
   // reserved words.

   symb := extension.level>=3 -> (TABLE s.slct,s.of,s.fix,s.float),bad
   D("SLCT OF FIX FLOAT")

   // EXTERNAL is declared similarly

   symb := extension.level>=4 -> (TABLE s.external), bad
   D("EXTERNAL")
$)

AND D(words) BE
$( LET i = 1
   LET length = 0

   $( LET ch = i>words%0 -> ' ', words%i

      TEST ch=' ' THEN $(
	 IF length=0 THEN RETURN
	 wordv%0 := length
	 LookUpWord()
	 h1!wordNode :=!symb
	 symb := symb+1
	 length := 0 $)
      ELSE $(
	 length := length+1
	 wordv%length := ch $)
      i := i+1
   $) REPEAT
$)


AND RCh() BE
$( ch := RdCh()

   IF ch='*N' | ch='*P' | ch='*C' THEN
   $( ch := '*N'
      lineCount := lineCount+1 $)
   chcount := chcount+1
   chbuf!(chcount & 63) := ch
$)

AND RdTag(char) BE
$( LET i = 1
   wordv%i := char

   $( LET cc = CapitalCh(ch)

      UNLESS 'A' <= cc <= 'Z' |
	     '0' <= ch <= '9' | ch='.' |
	     (ch='_' & extension.level>0) THEN
	BREAK

      i := i+1
      wordv%i := ch
      RCh()
   $) REPEAT
   wordv%0 := i
$)

AND PerformGet() BE
$( LET s = 0
   LET t = transchars

   transchars := FALSE
   NextSymb()
   transchars := t

   IF symb~=s.string | getp+2>getmax THEN SynReport(97)

   // Check for GET "" first - the meaning of this has
   // been changed so that it always refers to the source
   // file, even if a HDR parameter was given.
   //
   // Note that GET "" is an extension to standard BCPL.

   TEST wordv%0=0 THEN
      IF extension.level>=2 THEN
	 s := Open(fromfile, TRUE, FALSE)
   ELSE TEST headers=0 THEN $(
      s := Open(wordv, TRUE, FALSE)

      IF s=0 THEN $(
	 LET lenw = wordv%0
	 LET prefix = "$.alib."
	 LET plen = prefix%0
	 LET v = VEC 30/BytesPerWord

	 IF lenw>10 THEN lenw := 10

	 FOR i = 1 TO lenw DO v%(i+plen) := wordv%i
	 FOR i = 1 TO plen DO v%i := prefix%i
	 v%0 := lenw+plen
	 s := Open(v, TRUE, FALSE) $) $)

   ELSE $(
      LET file = find.header(wordv)

      IF file~=0 THEN $(
	 s := Open(file, TRUE, FALSE)
	 FreeVector(file) $) $)

   IF s=0 THEN SynReport(96, wordv)

   getv!getp := sourceStream
   getv!(getp+1) := lineCount
   getv!(getp+2) := ch
   getp := getp+3

   lineCount := 1

   sourceStream := s
   SelectInput(s)
   RCh()
$)

AND find.header(string) = VALOF
//
// Finds the file associated with the given header name
// in the HDR parameter.
//
// This has the format:
//
//   H1=F1,H2=F2,....Hn=Fn
//
// Each Hi is a header name (eg. LIBHDR), and each Fi is a
// file name.
//
// The result is a newly-allocated vector holding the file
// name, or zero if the header name was not found.
//
// The conditional compilation tag RDARGSL is set if HDR
// was read with the /L 'rdargs' options, in which case
// the length is in the first WORD, not byte.
//
$( LET hupb = headers%0
   LET hlwb = 1
   LET slen = string%0
   LET hpos = hlwb
   LET fpos = 0
   LET v = 0

   // Search through the HDR string to find the header
   // name.

   FOR j = hlwb TO hupb DO
   $( LET c = headers%j

      // A comma indicates the start of a header name,
      // an equals sign the end of one.

      TEST c=','
	 THEN hpos := j+1
	 ELSE IF c='=' THEN
	  //
	  // Does the current header name match the one
	  // that is being sought?
	  //
	  IF j-hpos=slen THEN
	  $( LET same = TRUE

	     FOR j = 1 TO slen DO
	       IF CompCh(headers%(j+hpos-1), string%j)~=0 THEN
	       $( same := FALSE
		  BREAK $)

	       // If found, remember the position at
	       // which the file name starts.

	       IF same THEN
	       $( fpos := j+1
		  BREAK $) $) $)

   IF fpos~=0 THEN
   $( LET flen = 0

      FOR j = fpos TO hupb DO
      $( IF headers%j=',' THEN BREAK
	 flen := flen+1 $)
      v := GetVector(flen / BytesPerWord+1)
      v%0 := flen

      FOR j = 1 TO flen DO
	 v%j := headers%(fpos+j-1) $)
   RESULTIS v
$)

AND ReadNumber(radix) BE
$( LET d = Value(ch);
   digits := 1;
   decval := d
   IF d>=radix THEN SynReport(33)

   $( RCh()
      d := Value(ch)
      IF d>=radix THEN RETURN;
      digits := digits+1;
      decval := radix * decval+d
   $) REPEAT
$)

AND ReadFloat() BE
$( LET negativeExponent = FALSE;
   symb := s.fconst;
   mantissa, exponent := decval, 0;
   IF ch='.' THEN
   $( Rch();
      UNLESS '0'<=ch<='9' THEN SynReport(33);
      ReadNumber(10);
      IF decval~=0 THEN
      $( exponent := exponent-digits;
	 WHILE digits~=0 DO
	 $( mantissa := mantissa*10;
	    digits := digits-1 $);
	 mantissa := mantissa+decval $) $);
   IF ch='E' | ch='e' THEN
   $( Rch();
      IF ch='-' THEN $( negativeExponent := TRUE; Rch() $);
      UNLESS '0'<=ch<='9' THEN SynReport(33);
      ReadNumber(10);
      exponent := negativeExponent -> exponent-decval,
				      exponent+decval $)
$)

AND Value(ch) = VALOF
$( LET c = CapitalCh(ch)
   RESULTIS '0'<=c<='9' -> c-'0',
	    'A'<=c<='F' -> c-'A'+10, 100
$)

AND RdStrCh(term, lv.ch) = VALOF
$( LET trans = transchars
   RCh()
   IF ch=term THEN RESULTIS FALSE
   IF ch='*N' THEN SynReport(34)

   IF ch='**' THEN
   $( RCh()
      IF ch='*N' | ch='*S' | ch='*T'
	 THEN TEST term='*''
	    THEN SynReport(34)
	    ELSE $( WHILE ch='*N' | ch='*S' | ch='*T' DO RCh()
		    IF ch~='**' THEN SynReport(34)
		    LOOP
		 $)

      ch := CapitalCh(ch)
      IF (ch='E' | ch='B' | ch='C') & extension.level=0 THEN
	 ch := -1

      SWITCHON ch INTO
      $( DEFAULT:  SynReport(35); ENDCASE

	 CASE 'T': ch := '*T';	  ENDCASE
	 CASE 'S': ch := '*S';	  ENDCASE
	 CASE 'N': ch := '*N';	  ENDCASE
	 CASE 'P': ch := '*P';	  ENDCASE
	 CASE 'B': ch := '*B';	  ENDCASE
	 CASE 'C': ch := '*C';	  ENDCASE
	 CASE 'E': ch := #X1B
	 CASE '"':                ENDCASE
	 CASE '*'':		  ENDCASE
	 CASE '**':		  ENDCASE

	 CASE 'X': CASE 'O':
	 CASE '0': CASE '1': CASE '2': CASE '3':
	 CASE '4': CASE '5': CASE '6': CASE '7':
	   $( LET r, n = 8, 3
	      IF ch='X' THEN r, n := 16, 2

	      IF ch='X' | ch='O' THEN RCh()
	      ch := ReadOctalOrHex(r, n)

	      IF ch>255 THEN SynReport(34)
	      trans := FALSE
	      ENDCASE
	   $)
      $)
   $)
   !lv.ch := trans -> charcode!ch, ch
   RESULTIS TRUE

$) REPEAT


AND ReadOctalOrHex(radix, digits) = VALOF
$( LET answer = 0

   FOR j = 1 TO digits DO
   $( LET valch = value(ch)
      IF valch>=radix THEN SynReport(34)

      answer := answer*radix+valch
      IF j~=digits THEN RCh()
   $)
   RESULTIS answer
$)

.

SECTION "Syn"

GET "b.Header"

STATIC
$( dummy = VersionMark;
   version = 1*256+2
$)

LET bcpl.syn() =  VALOF
$( LET a = 0;
   LET v = GetVector(nametablesize+64+wordmax+getmax+1);

   err.p := Level();
   err.l := exit;
   getp := 0;
   chcount := 0;
   externals.list := 0;
   free.list.element.chain := 0;
   free.ccstack.chain := 0;
   zeroNode := List2(s.number, 0);

   FOR i = 0 TO NameTableSize+63 DO v!i := 0

   nameTable := v
   chbuf := v+NameTableSize
   wordv := chbuf+64
   getv := wordv+wordmax

   initialise.lex()

   IF ch=EndStreamCh THEN GOTO exit

   rec.p, rec.l := err.p, l

l: NextSymb()

   $( LET RProg() = VALOF
      $( LET op, a = symb, 0
	 LET tag = ?

	 NextSymb()
	 IF symb~=s.string THEN SynReport(95)

	 tag := LookUpTag(wordv)
	 tag.value!tag := TRUE

	 a := RbExp()

	 IF op=s.section THEN WriteF("Section %S*N", a+1)

	 RESULTIS List3(op, a, symb=s.needs -> RProg(),
					       RdBlockBody())
      $)

      a := extension.level>=1 &
	   [symb=s.section | symb=s.needs] -> RProg(),
					      RdBlockBody()

      IF symb~=s.end THEN SynReport(99)
   $)
   UnRdCh()

exit:
   FreeVector(v)
   RESULTIS a
$)

AND List1(x) = VALOF
$( LET p = GetBlk(1)
   p!0 := x
   RESULTIS p
$)

AND List2(x, y) = VALOF
$( LET p = GetBlk(2)
   p!0, p!1 := x, y
   RESULTIS p
$)

AND List3(x, y, z) = VALOF
$( LET p = GetBlk(3)
   p!0, p!1, p!2 := x, y, z
   RESULTIS p
$)

AND List4(x, y, z, t) = VALOF
$( LET p = GetBlk(4)
   p!0, p!1, p!2, p!3 := x, y, z, t
   RESULTIS p
$)

AND List5(x, y, z, t, u) = VALOF
$( LET p = GetBlk(5)
   p!0, p!1, p!2, p!3, p!4 := x, y, z, t, u
   RESULTIS p
$)

AND List6(x, y, z, t, u, v) = VALOF
$( LET p = GetBlk(6)
   p!0, p!1, p!2, p!3, p!4, p!5 := x, y, z, t, u, v
   RESULTIS p
$)

AND GetListElement() = VALOF
// Gets a new element for a 'makelist' chain, and
// initialises the count and link fields to zero.
//
$( LET q = free.list.element.chain
   TEST q=0
      THEN q := GetBlk(list.element.size)
      ELSE free.list.element.chain := list.link!q

   list.link !q := 0
   list.count!q := 0

   RESULTIS q
$)

AND InsertInListElement(lv.element, data) BE
// Inserts the data in the list element addressed by
// the pointer parameter.
//
$( LET element = !lv.element
   LET c = list.count!element

   IF c=list.element.data.size THEN
   $( LET n = GetListElement()

      list.link!element := n
      !lv.element := n
      element := n

      c := 0 $)
   (list.data+element)!c := data
   list.count!element := c+1
$)


AND MakeList(list,listend,type1,type2,count,unitsize)=VALOF
// Converts a list formed out of list elements into a
// straight table.
//
//   list	first element in list
//   listend	last  element in list
//   type1	tree type for table
//   type2	type used for pair of units
//   count	number of data words
//   unitsize	size of a single 'object' in the list
//
// If the unitsize is one, and there is one value in the
// list, a table is not constructed.
//
// If there are two objects and 'type2' is not zero, a
// pair object is returned.
//
$( LET result = ?

   TEST count=1 & unitsize=1
      THEN result := list.data!list
      ELSE $( LET l = list
	      LET p = 1

	      TEST count=2*unitsize & type2~=0
		 THEN $( result := GetBlk(count+1)
			 h1!result := type2
		      $)
		 ELSE $( result := GetBlk(count+2)
			 h1!result := type1
			 h2!result := count
			 p := 2
		      $)

	      WHILE l~=0 DO
	      $( FOR j = 0 TO list.count!l-1 DO
		 $( result!p := (list.data+l)!j
		    p := p+1
		 $)
		 l := list.link!l
	      $)
	   $)

   // Add list to chain of free elements

   list.link!listend := free.list.element.chain
   free.list.element.chain := list

   RESULTIS result
$)

AND SynReport(n, a) BE
$( LET s = VALOF SWITCHON n INTO
   $( DEFAULT: a := n
	       RESULTIS "Error %N"

      CASE 1:  RESULTIS "Bad tag setting expression"
      CASE 2:  RESULTIS "Bad tag name"
      CASE 3:  RESULTIS "End of file while skipping text"
      CASE 4:  RESULTIS "Tag conditions do not match"
      CASE 5:  RESULTIS "Bad conditional compilation nesting"

      CASE  6: RESULTIS "'$(' expected"
      CASE  7: RESULTIS "'$)' expected"
      CASE  8:
      CASE 40:
      CASE 43: RESULTIS "Name expected"
      CASE  9: RESULTIS "Untagged '$)' mismatch"
      CASE 15:
      CASE 19:
      CASE 41: RESULTIS "')' missing"
      CASE 30: RESULTIS "Bad conditional expression"
      CASE 32: RESULTIS "Invalid expression"
      CASE 33: RESULTIS "Bad number"
      CASE 34: RESULTIS "Bad string or character constant"
      CASE 35: RESULTIS "Bad escape in string or character"
      CASE 42: RESULTIS "Bad procedure heading"
      CASE 44:
      CASE 45: RESULTIS "Bad declaration"
      CASE 50: RESULTIS "Unexpected ':'"
      CASE 51: RESULTIS "Invalid command"
      CASE 54: RESULTIS "'ELSE' expected"
      CASE 57:
      CASE 58: RESULTIS "Bad FOR loop"
      CASE 60: RESULTIS "'INTO' expected"
      CASE 61:
      CASE 62: RESULTIS "':' expected"
      CASE 63: RESULTIS "'**/' missing"
      CASE 91: RESULTIS "'$' out of context"
      CASE 94: RESULTIS "Illegal character"
      CASE 95: RESULTIS "Illegal section name"
      CASE 96: rc := 20
	       RESULTIS "Can't GET *"%S*" - "
      CASE 97: RESULTIS "Bad GET directive"
      CASE 99: RESULTIS "Incorrect termination"
      CASE 100:RESULTIS "Bad external name string"
      CASE 101:RESULTIS "Invalid use of symbol"
   $)

   IF rc<10 THEN rc := 10

   WriteF("*NError near line %N:  ", lineCount)
   WriteF(s, a)

brk:
   IF rc>=20 THEN
   $( WriteS("compilation abandoned*N")

      WHILE getp~=0 DO
      $( Close(sourceStream)
	 getp := getp-3
	 sourceStream := getv!getp
	 SelectInput(sourceStream)
      $)
      LongJump(err.p,err.l)
   $)
   WrChBuf()
   nlPending := FALSE

   UNTIL symb=s.lsect | symb=s.rsect |
	 symb=s.let   | symb=s.and   |
	 symb=s.end   | nlPending DO NextSymb()

   LongJump(rec.p, rec.l)
$)

AND WrChBuf() BE
$( WriteS("*N...")

   FOR p = chcount-63 TO chcount DO
   $( LET k = chbuf!(p&63)
      IF k>0 THEN WrCh(k)
   $)
   NewLine()
$)

AND RdBlockBody() = VALOF
$( LET p, l = rec.p, rec.l
   LET a = 0
   LET ptr = @a

   $( LET op = 0
      rec.p, rec.l := Level(), recover
      Ignore(s.semicolon)

      SWITCHON symb INTO
      $( CASE s.manifest:
	 CASE s.static:
	 CASE s.global:
	 CASE s.external:
	   op := symb
	   NextSymb()
	   !ptr := RdSect(RdCDefs, op)
	   ENDCASE

	 CASE s.let:
	   NextSymb()
	   !ptr := RDef()
  recover:
	   $( LET qtr = ptr

	      WHILE symb=s.and DO
	      $( NextSymb()
		 !qtr := List3(s.and, !qtr, RDef())
		 qtr := @h3!(!qtr)
	      $)
	      op := s.let
	      ENDCASE
	   $)

	 DEFAULT:
	   !ptr := RdSeq()
	   IF symb~=s.rsect & symb~=s.end THEN SynReport(51)

	 CASE s.rsect: CASE s.end:
	   BREAK
      $)
      !ptr := List3(op,!ptr, 0)
      ptr := @h3!(!ptr)

   $) REPEAT
   rec.p, rec.l := p, l
   RESULTIS a
$)

AND RdSeq() = VALOF
$( LET n = 0
   LET list = GetListElement()
   LET liste = list

   $( LET lc = ?
      Ignore(s.semicolon)

      lc := lineCount
      InsertInListElement(@liste, rcom())
      InsertInListElement(@liste, lc)
      n :=  n+2

   $) REPEATUNTIL symb=s.rsect | symb=s.end

   RESULTIS MakeList(list, liste, s.semicolonlist,
				  s.semicolon, n, 2)
$)

AND RdCDefs(op) = VALOF
$( LET n =  0
   LET list = GetListElement()
   LET liste = list
   LET p, l = rec.p, rec.l

   $( LET lc = ?
      LET e = 0

      rec.p, rec.l := Level(), rec

      InsertInListElement(@liste, RName())
      lc := lineCount

      IF symb~=s.eq & symb~=s.colon THEN SynReport(45)

      NextSymb()

      TEST op=s.external
	 THEN $( IF symb~=s.string THEN SynReport(100)
		 e := List4(externals.list, RbExp()+1, 0, 0)
		 externals.list := e
	      $)
	 ELSE e := RExp(0)

rec:  n := n+3
      InsertInListElement(@liste, e)
      Ignore(s.semicolon)
      InsertInListElement(@liste, lc)

   $) REPEATWHILE symb=s.name

   rec.p, rec.l := p, l

   RESULTIS MakeList(list, liste, s.semicolonlist, 0, n,3)
$)

AND RdSect(r, arg) = VALOF
$( LET tag, a = wordNode, 0

   CheckFor(s.lsect, 6)
   a := r(arg)

   IF symb~=s.rsect THEN SynReport(7)

   TEST tag=wordNode
      THEN NextSymb()
      ELSE IF wordNode=nulltag THEN
       $( symb := 0
	  SynReport(9)
       $)
   RESULTIS a
$)

AND RNamelist() = VALOF
$( LET n =  0
   LET list = GetListElement()
   LET liste = list

   $( InsertInListElement(@liste, RName())
      n := n+1
      IF symb~=s.comma THEN BREAK
      NextSymb()
   $) REPEAT

   RESULTIS MakeList(list,liste,s.commalist,s.comma,n,1)
$)

AND RName() = VALOF
$( LET a = wordNode
   CheckFor(s.name, 8)
   RESULTIS a
$)

AND Ignore(item) BE
  IF symb=item THEN
    NextSymb()

AND CheckFor(item, n) BE
$( IF symb~=item THEN SynReport(n)
   NextSymb()
$)

AND RbExp() = VALOF
$( LET a, op = 0, symb

   SWITCHON symb INTO
   $( DEFAULT:
	SynReport(32)

      CASE s.bad:
	SynReport(101)

      CASE s.query:
	NextSymb()
	RESULTIS List1(s.query)

      CASE s.true: CASE s.false:
      CASE s.name:
      CASE s.nil:
	a := wordNode
	NextSymb()
	RESULTIS a

      CASE s.string:
	$( LET wordSize = wordv%0 / BytesPerWord
	   a := GetBlk(wordSize+2)
	   a!0 := s.string

	   FOR i = 0 TO wordSize DO a!(i+1) := wordv!i
	   NextSymb()
	   RESULTIS a
	$)

      CASE s.number:
	$( LET k = decval
	   NextSymb()

	   RESULTIS k=0     -> zeroNode,
	     SmallNumber(k) -> k,
			       List2(s.number, k)
	$)

      CASE s.fconst:
	$( LET i, j = mantissa, exponent;
	   NextSymb();
	   RESULTIS List3(s.fconst, i, j)
	$)

      CASE s.lparen:
	NextSymb()
	a := RExp(0)
	CheckFor(s.rparen, 15)
	RESULTIS a

      CASE s.valof:
	NextSymb()
	RESULTIS List2(s.valof, RCom())

      CASE s.vecap:
	op := s.rv

      CASE s.lv:
      CASE s.rv:
      CASE s.car: CASE s.vcar:
      CASE s.cdr: CASE s.vcdr:
	NextSymb()
	RESULTIS List2(op, RExp(37))

      CASE s.plus:
	NextSymb()
	RESULTIS RExp(34)

      CASE s.minus:
	NextSymb()
	a := RExp(34)

	RESULTIS SmallNumber(a) -> List2(s.number, -a),
				   List2(s.neg, a)

      CASE s.fminus:
	NextSymb();
	RESULTIS List2(s.fneg, RExp(34))

      CASE s.not:
	NextSymb()
	RESULTIS List2(s.not, RExp(24))

      CASE s.abs:
      CASE s.fabs:
      CASE s.float: CASE s.fix:
	NextSymb()
	RESULTIS List2(op, RExp(35))

      CASE s.table:
	$( LET ln = lineCount
	   NextSymb()
	   RESULTIS List4(s.table, -1, ln, RExpList())
	$)

      CASE s.slct:
	$( LET k1 = zeroNode
	   LET k2 = zeroNode
	   LET k3 = ?

	   NextSymb()
	   k3 := RExp(0)

	   IF symb=s.colon THEN
	   $( NextSymb()
	      k2 := k3
	      k3 := RExp(0)
	   $)

	   IF symb=s.colon THEN
	   $( NextSymb()
	      k1 := k2
	      k2 := k3
	      k3 := RExp(0)
	   $)

	   RESULTIS List4(s.slct, k1, k2, k3)
	$)
   $)
$)

AND RExp(n) = VALOF
$( LET a = RbExp()
   LET b, c, p, q = 0, 0, 0, 0

   $( LET op = symb
      IF nlPending THEN RESULTIS a

      SWITCHON op INTO
      $( DEFAULT:
	   RESULTIS a

	 CASE s.lparen:
	   NextSymb()
	   b := 0
	   IF symb~=s.rparen THEN b := RExpList()

	   CheckFor(s.rparen, 19)
	   a := List3(s.fnap, a, b)
	   LOOP

	 CASE s.vecap:
	 CASE s.of:	p := 40; GOTO lassoc

	 CASE s.byteap: p := 36; GOTO lassoc

	 CASE s.mult: CASE s.div: CASE s.rem:
	 CASE s.fmult:CASE s.fdiv:
			p := 35; GOTO lassoc

	 CASE s.plus: CASE s.minus:
	 CASE s.fplus:CASE s.fminus:
			p := 34; GOTO lassoc

	 CASE s.lshift:
	 CASE s.rshift: p, q := 25, 30; GOTO dyadic

	 CASE s.logand: p := 23; GOTO lassoc

	 CASE s.logor:	p := 22; GOTO lassoc

	 CASE s.eqv:
	 CASE s.neqv:	p := 21; GOTO lassoc

	 CASE s.eq:  CASE s.ne:
	 CASE s.le:  CASE s.ge:  CASE s.ls:  CASE s.gr:
	 CASE s.feq: CASE s.fne:
	 CASE s.fle: CASE s.fge: CASE s.fls: CASE s.fgr:
	 CASE s.lle: CASE s.lge: CASE s.lls: CASE s.lgr:
	   IF n>=30 THEN RESULTIS a

	   $( NextSymb()
	      b := RExp(30)
	      a := List3(op, a, b)
	      c := c=0 -> a, List3(s.logand, c, a)
	      a, op := b, symb

	   $) REPEATWHILE (s.eq<=op<=s.ge) |
			  (s.lls<=op<=s.lge) |
			  (s.feq<=op<=s.fge)
	   a := c
	   LOOP

	 CASE s.cond:
	   IF n>=13 THEN RESULTIS a

	   NextSymb()
	   b := RExp(0)
	   CheckFor(s.comma, 30)
	   a := List4(s.cond, a, b, RExp(0))
	   LOOP
      $)
lassoc:
      q := p
dyadic:
      IF n>=p THEN RESULTIS a
      NextSymb()
      a := List3(op, a, RExp(q))
   $) REPEAT
$)

AND RExpList() = VALOF
$( LET a = 0
   LET n = 0
   LET list = GetListElement()
   LET liste = list

   $( InsertInListElement(@liste, RExp(0))
      n := n+1
      IF symb~=s.comma THEN BREAK
      NextSymb()
   $) REPEAT

   RESULTIS MakeList(list,liste,s.commalist,s.comma,n,1)
$)


AND RDef() = VALOF
$( LET n = RNamelist()

   SWITCHON symb INTO
   $( CASE s.lparen:
	$( LET a = 0
	   LET ln = lineCount
	   NextSymb()

	   IF h1!n~=s.name THEN SynReport(40)
	   IF symb=s.name THEN a := RNamelist()

	   CheckFor(s.rparen, 41)

	   IF symb=s.be THEN
	   $( NextSymb()
	      RESULTIS List6(s.rtdef, n, a, RCom(), 0, ln) $)

	   IF symb=s.eq THEN
	   $( NextSymb()
	      RESULTIS List6(s.fndef, n, a, RExp(0), 0, ln) $)
	   SynReport(42)
	$)

      DEFAULT:
	SynReport(44)

      CASE s.eq:
	$( LET ln = lineCount
	   NextSymb()

	   IF symb=s.vec THEN
	   $( NextSymb()
	      IF h1!n~=s.name THEN SynReport(43)
	      RESULTIS List4(s.vecdef, n, RExp(0), ln) $)

	   RESULTIS List4(s.valdef, n, RExpList(), ln)
	$)
   $)
$)


AND RbCom() = VALOF
$( LET a, b, op = 0, 0, symb

   SWITCHON symb INTO
   $( DEFAULT:
	RESULTIS 0

      CASE s.bad:
	SynReport(101)

      CASE s.name: CASE s.number: CASE s.string:
      CASE s.true: CASE s.false:  CASE s.lv:
      CASE s.rv:   CASE s.vecap:  CASE s.lparen:
      CASE s.car:  CASE s.cdr:
      CASE s.vcar: CASE s.vcdr:
      CASE s.nil:
	a := RExpList()

	IF symb=s.ass THEN
	$( op := symb
	   NextSymb()
	   RESULTIS List3(op, a, RExpList()) $)

	IF symb=s.opab THEN
	  //
	  // The node is of type 'OPAB', with the
	  // actual operator in the second field.
	  //
	$( LET dyadic = operator
	   op := symb
	   NextSymb()
	   RESULTIS List4(op, dyadic, a, RExpList()) $)

	IF SmallNumber(a) THEN SynReport(51)

	IF symb=s.colon THEN
	$( IF h1!a~=s.name THEN SynReport(50)
	   NextSymb()
	   RESULTIS List4(s.colon, a, RbCom(), 0) $)

	IF h1!a=s.fnap THEN
	$( h1!a := s.rtap
	   RESULTIS a $)

	SynReport(51)
	RESULTIS a

      CASE s.goto: CASE s.resultis:
	NextSymb()
	RESULTIS List2(op, RExp(0))

      CASE s.if:    CASE s.unless:
      CASE s.while: CASE s.until:
	NextSymb()
	a := RExp(0)
	Ignore(s.do)
	RESULTIS List3(op, a, RCom())

      CASE s.test:
	NextSymb()
	a := RExp(0)
	Ignore(s.do)
	b := RCom()
	CheckFor(s.or, 54)
	RESULTIS List4(s.test, a, b, RCom())

      CASE s.for:
	$( LET i, j, k = 0, 0, 0

	   NextSymb()
	   a := RName()
	   CheckFor(s.eq,57)

	   i := RExp(0)
	   CheckFor(s.to, 58)

	   j := RExp(0)

	   IF symb=s.by THEN
	   $( NextSymb()
	      k := RExp(0) $)

	   Ignore(s.do)
	   RESULTIS List6(s.for, a, i, j, k, RCom())
	$)

      CASE s.loop:   CASE s.break: CASE s.endcase:
      CASE s.return: CASE s.finish:
	a := wordNode
	NextSymb()
	RESULTIS a

      CASE s.switchon:
	$( LET cc = caseCount
	   LET res = ?
	   LET sect = ?

	   NextSymb()
	   a := RExp(0)
	   CheckFor(s.into, 60)

	   caseCount := 0
	   sect := RdSect(RdSeq)
	   res := List4(s.switchon, a, sect, caseCount)
	   caseCount := cc

	   RESULTIS res
	$)

      CASE s.case:
	NextSymb()
	a := RExp(0)
	CheckFor(s.colon, 61)
	caseCount := caseCount+1
	RESULTIS List3(s.case, a, RbCom())

      CASE s.default:
	NextSymb()
	CheckFor(s.colon, 62)
	RESULTIS List2(s.default, RbCom())

      CASE s.lsect:
	RESULTIS RdSect(RdBlockBody)
   $)
$)

AND RCom() = VALOF
$( LET a = RbCom()

   IF a=0 THEN SynReport(51)

   WHILE symb=s.repeat | symb=s.repeatwhile | symb=s.repeatuntil DO
   $( LET op = symb
      NextSymb()
      a := op=s.repeat -> List2(op, a),
			  List3(op, a, RExp(0)) $)

   RESULTIS a
$)

