COMMENT ⊗   VALID 00005 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	{$NOMAIN	Editor: Token-fetching routines }
C00031 00003	{ Externally defined routines from elsewhere: }
C00034 00004	(* Token routines: copyToken, getToken *)
C00056 00005	(* aux routines for parsing expressions: dimCheck, getDelim *)
C00058 ENDMK
C⊗;
{$NOMAIN	Editor: Token-fetching routines }

(* definition of record types & global variables used by AL *)

const 

  maxLines = 28;
  maxPPLines = 18;
  maxBpts = 25;
  maxTBpts = 20;	(* max could be exceeded by huge case stmnt *)
  listinglength = 2000;	(* Length of Listingarray *)

type

(* random type declarations for OMSI/SAIL compatibility *)

 ascii = char;
 atext = text;
 byte = 0..255;	

(* Here are all the pointer-type definitions.  Since the various 	*)
(* records reference each other so much, we have to put them all here.	*)

vectorp = ↑vector;
transp = ↑trans;
strngp = ↑strng;
eventp = ↑event;
framep = ↑frame;
statementp = ↑statement;
varidefp = ↑varidef;
nodep = ↑node;
identp = ↑ident;
tokenp = ↑token;
reswordp = ↑resword;
pdbp = ↑pdb;
envheaderp = ↑envheader;
enventryp = ↑enventry;
environp = ↑environment;
cmoncbp = ↑cmoncb;
messagep = ↑message;
linerecp = ↑linerec;


(* datatype definitions *)

datatypes = (pconstype, varitype, svaltype, vectype, rottype, transtype,
	     frametype, eventtype, strngtype, labeltype, proctype, arraytype,
	     reftype, valtype, cmontype, nulltype, undeftype,
	     dimensiontype, mactype, macargtype, freevartype);

scalar = real;
vector = record  refcnt: integer; val: array [1..3] of real end;
trans = record  refcnt: integer; val: array [1..3,1..4] of real end;

cstring = packed array [1..10] of ascii;
c4str = packed array [1..4] of ascii;
c5str = packed array [1..5] of ascii;
c20str = packed array [1..20] of ascii;
linestr = packed array [1..130] of ascii;

strng = record
	  next: strngp;
	  ch: cstring;
	end;

event = record
	  next: eventp;		(* all events are on one big list *)
	  count: integer;
	  waitlist: pdbp;
	end;

frame = record
	  vari: varidefp;	(* back pointer to variable name & info *)
	  calcs: nodep;		(* affixment info *)
	  case ftype: boolean of	(* frame = true, device = false *)
  true:	    (valid: integer; val, fdepr: transp; dcntr: integer; dev: framep);
  false:    (mech: integer; case sdev: boolean of
		true: (sdest: real); false: (tdest,appr,depr: transp));
		(* sdev = true for scalar devices, false for frames *)
	end;


(* statement definitions *)

stmntypes = (progtype, blocktype, coblocktype, endtype, coendtype,
		fortype, iftype, whiletype, untiltype, casetype,
		calltype, returntype,
		printtype, prompttype, pausetype, aborttype, assigntype,
		signaltype, waittype, enabletype, disabletype, cmtype,
		affixtype, unfixtype,
		movetype,jtmovetype,operatetype,opentype,closetype,centertype,
		floattype, stoptype, retrytype,
		requiretype, definetype, macrotype, commenttype, dimdeftype,
		setbasetype, wristtype, saytype, declaretype, emptytype,
		evaltype, armmagictype);
		(* more??? *)

statement = packed record
		next, last: statementp;
		stlab: varidefp;
		exprs: nodep;	(* any expressions used by this statement *)
		nlines: integer;
		bpt,bad: boolean;
		case stype: stmntypes of

    progtype:	    (pcode: statementp; errors: integer);
    blocktype,
    declaretype,
    endtype,
    coendtype:	    (bcode, bparent: statementp; blkid: identp;
			level, numvars: 0..255; variables: varidefp);
    coblocktype:    (threads: nodep; nthreads: integer; cblkid: identp);
    definetype:	    (macname,mpars: varidefp; macdef: tokenp);
		end;



(* auxiliary definitions: variable, etc. *)

varidef = packed record
	    next,dnext: varidefp;
	    name: identp;
	    level: 0..255;	(* environment level *)
	    offset: 0..255;	(* environment offset *)
	    dtype: varidefp;	(* to hold the dimension info *)
	    tbits: 0..15;  (* special type bits: array = 1, proc = 2, ref = 4 & ? *)
	    dbits: 0..15;	(* for use by debugger/interpreter *)
	    case vtype: datatypes of
  arraytype:  (a: nodep);
  proctype:   (p: nodep);
  labeltype,
  cmontype:   (s: statementp);
  mactype:    (mdef: statementp);
  macargtype: (marg: tokenp);
  pconstype:  (c: nodep);
  dimensiontype: (dim: nodep);
	  end;



(* definition of the ubiquitous NODE record *)

nodetypes = (exprnode, leafnode, listnode, clistnode, colistnode, forvalnode,
		deprnode, viaptnode, apprnode, destnode, byptnode, durnode,
		sfacnode, wobblenode, swtnode, nullingnode, wristnode, cwnode,
		arrivalnode, departingnode,
		ffnode, forcenode, stiffnode, gathernode, cmonnode, errornode,
		calcnode, arraydefnode, bnddefnode, bndvalnode,
		waitlistnode, procdefnode, tlistnode, dimnode, commentnode,
		linearnode, elbownode, shouldernode, flipnode, wrtnode,
		loadnode,velocitynode);

exprtypes =  (	svalop,					(* scalar operators *)
		sltop, sleop, seqop, sgeop, sgtop, sneop,	(* relations *)
		notop, orop, xorop, andop, eqvop,		(* logical *)
		saddop, ssubop, smulop, sdivop, snegop, sabsop, (* scalar ops *)
		sexpop, maxop, minop, intop, idivop, modop,
		sqrtop, logop, expop, timeop,			(* functions *)
		sinop, cosop, tanop, asinop, acosop, atan2op,	(* trig *)
		vdotop, vmagnop, tmagnop,
		vecop,					(* vector operators *)
		vmakeop, unitvop, vaddop, vsubop, crossvop, vnegop,
		svmulop, vsmulop, vsdivop, tvmulop, wrtop,
		tposop, taxisop,
		transop,				(* trans operators *)
		tmakeop, torientop, ttmulop, tvaddop, tvsubop, tinvrtop,
		vsaxwrop, constrop, ftofop, deproachop, fmakeop, vmkfrcop,
		ioop,					(* i/o operators *)
		queryop, inscalarop,
		specop,					(* special operators *)
		arefop, callop, grinchop, macroop, vmop, adcop, dacop, jointop,
		badop,
		addop, subop, negop, mulop, divop, absop); (* for parsing *)

leaftypes = pconstype..strngtype;

reltypes = sltop..sgtop;
forcetypes = (force,absforce,torque,abstorque,angvelocity);

node = record
	next: nodep;
	case ntype: nodetypes of
    exprnode:	(op: exprtypes; arg1, arg2, arg3: nodep; elength: integer);
    leafnode:	(case ltype: leaftypes of
	varitype:  (vari: varidefp; vid: identp);
	pconstype: (cname: varidefp; pcval: nodep);
	svaltype:  (s: scalar; wid: integer);
	vectype:   (v: vectorp);
	transtype: (t: transp);
	strngtype: (length: integer; str: strngp) ); (* also used by commentnodes *)
    listnode:	(lval: nodep);
    clistnode:	(cval: integer; stmnt: statementp; clast: nodep);
    colistnode:	(prev: nodep; cstmnt: statementp);
    tlistnode:	(tok: tokenp);
	end;



(* records for parser: ident, token, resword *)

ident = record
	    next: identp;
	    length: integer;
	    name: strngp;
	    predefined: varidefp;
	  end;


tokentypes = (reswdtype, identtype, constype, comnttype, delimtype, labeldeftype,
		macpartype);

constypes = svaltype..strngtype;

reswdtypes = (stmnttype, filtype, clsetype, decltype, optype, edittype);

filtypes = (abouttype,alongtype,attype,bytype,defertype,dotype,elsetype,
		errmodestype,fromtype,handtype,intype,nonrigidlytype,rigidlytype,
		sourcefiletype,steptype,thentype,totype,untltype,viatype,
		withtype,worldtype,zeroedtype,oftype,wheretype,nowaittype,
		ontype,offtype,ppsizetype,collecttype,alltype,lextype,
		notype,righttype,lefttype,uptype,downtype,motiontype);

clsetypes = (approachtype,arrivaltype,departuretype,departingtype,durationtype,
		errortype,forcetype,forceframetype,forcewristtype,gathertype,
		nildeproachtype,nullingtype,stiffnesstype,
		torquetype,velocitytype,wobbletype,
		cwtype,ccwtype,stopwaittimetype,angularvelocitytype,
		respecttype,elbowtype,shouldertype,fliptype,lineartype,
		jointspacetype,loadtype);

edittypes = (getcmd,savecmd,insertcmd,renamecmd,startcmd,gocmd,proceedcmd,
		stepcmd,sstepcmd,nstepcmd,gstepcmd,executecmd,setcmd,tracecmd,
		breakcmd,unbreakcmd,tbreakcmd,definecmd,markcmd,unmarkcmd,
		popcmd,atcmd,calibratecmd);

token = record
	  next: tokenp;
	  case ttype: tokentypes of
constype:   (cons: nodep);
comnttype:  (len: integer; str: strngp);
delimtype:  (ch: ascii);
reswdtype:  (case rtype: reswdtypes of
	stmnttype: (stmnt: stmntypes);
	filtype:   (filler: filtypes);
	clsetype:  (clause: clsetypes);
	decltype:  (decl: datatypes);
	optype:	   (op: exprtypes);
	edittype:  (ed: edittypes) );
identtype:  (id: identp);
labeldeftype: (lab: varidefp);
macpartype: (mpar: varidefp);
	end;


resword = record
	  next: reswordp;
	  length: integer;
	  name: strngp;
	  case rtype: reswdtypes of
	stmnttype:  (stmnt: stmntypes);
	filtype:    (filler: filtypes);
	clsetype:   (clause: clsetypes);
	decltype:   (decl: datatypes);
	optype:	    (op: exprtypes);
	edittype:  (ed: edittypes);
	  end;



(* process descriptor blocks & environment record definitions *)

queuetypes = (nullqueue,nowrunning,runqueue,inputqueue,eventqueue,sleepqueue,
		forcewait,devicewait,joinwait,proccall);

pdb = packed record
	nextpdb,next: pdbp;	(* for list of all/active pdb's *)
	level: 0..255;		(* lexical level *)
	mode: 0..255;		(* expression/statement/sub-statement *)
	priority: 0..255;	(* probably never greater than 3? *)
	status: queuetypes;	(* what are we doing *)
	env: envheaderp;
	spc: statementp;	(* current statement *)
	epc: nodep;		(* current expression (if any) *)
	sp: nodep;		(* intermediate value stack *)
	cm: cmoncbp;		(* if we're a cmon point to our definition *)
	mech: framep;		(* current device being used *)
	linenum: integer;	(* used by editor/debugger *)
	 case procp: boolean of	(* true if we're a procedure *)
true:  (opdb: pdbp;		(* pdb to restore when procedure exits *)
	pdef: nodep);		(* procedure definition node *)
false: (evt: eventp;		(* event to signal when process goes away *)
	sdef: statementp);	(* first statement where process was defined *)
      end;


envheader = packed record
	      parent: envheaderp;
	      env: array [0..4] of environp;
	      varcnt: 0..255;		(* # of variables in use ??? *)
		case procp: boolean of  (* true if we're a procedure *)
	true: (proc: nodep);
	false:(block: statementp);
	    end;

enventry = record
	    case etype: datatypes of
  svaltype:  (s: scalar);
  vectype:   (v: vectorp);
  transtype: (t: transp);
  frametype: (f: framep);
  eventtype: (evt: eventp);
  strngtype: (length: integer; str: strngp);
  cmontype:  (c: cmoncbp);
  proctype:  (p: nodep; penv: envheaderp);
  reftype:   (r: enventryp);
  arraytype: (a: envheaderp; bnds: nodep);
	   end;


environment = record
		next: environp;
		vals: array [0..9] of enventryp;
	      end;


cmoncb = record
	   running, enabled: boolean;		(* cmon's status *)
	   cmon: statementp;
	   pdb: pdbp;
	   evt: eventp;
	   fbits: integer;			(* bits for force sensing *)
	   oldcmon: cmoncbp;			(* for debugger *)
	 end;



(* definition of AL-ARM messages *)

msgtypes = (initarmscmd,calibcmd,killarmscmd,wherecmd,
	    abortcmd,stopcmd,movehdrcmd,movesegcmd,
	    centercmd,operatecmd,movedonecmd,signalcmd,
	    setccmd,forcesigcmd,forceoffcmd,biasoncmd,biasoffcmd,setstiffcmd,
	    zerowristcmd,wristcmd,gathercmd,getgathercmd,readadccmd,writedaccmd,
	    errorcmd,floatcmd,setloadcmd,
	    armmagiccmd,realcmd,vectorcmd,transcmd);

errortypes = (noerror,noarmsol,timerr,durerr,toolong,featna,
	      unkmess,srvdead,adcdead,nozind,exjtfc,paslim,nopower,badpot,devbusy,
	      baddev,timout,panicb,nocart,cbound,badparm);

message = record
	   cmd: msgtypes;
	   ok: boolean;
	   case integer of
	1:   (dev, bits, n: integer;
(*	     (dev, bits, n, evt: integer;	(* for arm code version *)
	      evt: eventp;
	      dur: real;
	      case integer of
		1: (v1,v2,v3: real);
		2: (sfac,wobble,pos: real);
		3: (val,angle,mag: real);
		4: (max,min: real);
		5: (error: errortypes));
	2:   (fv1,fv2,fv3,mv1,mv2,mv3: real);	(* may never use these... *)
	3:   (t: array [1..6] of real);
	  end;

interr = record
         case integer of
           0: (i: integer);
	   1: (err,foo: errortypes);
	 end;



(* print related records: *)

cursorp = record
	  cline,ind: integer;
	  case stmntp: boolean of
  true:    (st: statementp);
  false:   (nd: nodep);
	 end;

linerec = record
	next: linerecp;
	start,length: integer
       end;

listingarray = packed array [0..listinglength] of ascii;



(* global variables *)

var
	(* from EDIT *)
    listing: listingarray;  (* first 150 chars are used by expression editor *)
			    (* next 40 by header & trailer lines *)
{*} cursorStack: array [1..15] of cursorp;	{These are BIG records! }
    lbuf: array [1..160] of ascii;
    ppBuf: array [1..100] of ascii;
    lines: array [1..maxLines] of linerecp; (* what's on the screen + some *)
    ppLines: array [1..maxPPLines] of linerecp;	(* for page printer *)
    marks: array [1..20] of integer;
    reswords: array [0..26] of reswordp;
    idents: array [0..26] of identp;
    macrostack: array [1..10] of tokenp;
    curmacstack: array [1..10] of varidefp;
    screenheight,dispHeight: integer;
    ppBufp,oppBufp,ppOffset,ppSize,nmarks: integer;
    lbufp,cursor,ocur,cursorLine,fieldnum,lineNum,findLine,pcLine: integer;
    firstDline,topDline,botDline,firstLine,lastLine,curLine: integer;
    freeLines,oldLines: linerecp;
    sysVars: varidefp;
    dProg: statementp;
    curBlock, newDeclarations, findStmnt: statementp;
    macrodepth: integer;
    filedepth, errCount, sCursor: integer;
    curChar, maxChar, curFLine, curPage: integer;
    nodim, distancedim, timedim, angledim,
      forcedim, torquedim, veldim, angveldim: varidefp;
    fvstiffdim, mvstiffdim: nodep;
    pnode: nodep;
    smartTerminal: boolean; (* true = insert/delete, false = redraw line *)
    setUp,setExpr,setCursor,dontPrint,outFilep,collect,fParse,sParse,
      eofError,endOfLine,backup,expandmacros,flushcomments,checkDims,
      shownLine: boolean;
    curtoken: token;
    file1,file2,file3,file4,file5,outFile: atext;

    bpts: array [1..maxBpts] of statementp;	(* debugging crap *)
    tbpts: array [1..maxTBpts] of statementp;
    debugPdbs: array [0..10] of pdbp;
    nbpts,ntbpts,debugLevel: integer;
    eCurInt: pdbp;
    STLevel: integer;		(* set by GO *)
    singleThreadMode,tSingleThreadMode: boolean;

	(* from INTERP *)
    inputLine: array [1..20] of ascii;
    talk: text;			(* for using the speech synthesizer *)
    curInt, activeInts, readQueue, allPdbs: pdbp;
    sysEnv: envheaderp;
    clkQueue: nodep;
    allEvents: eventp;
    etime: integer;		(* used by eval *)
    curtime: integer; (* who knows where this will get updated - an ast? *)
    stime: integer;		(* used for clock queue on 10 *)
    msg: messagep;		(* for AL-ARM interaction *)
    inputp: integer;		(* current offset into inputLine array above *)
    resched, running, escapeI, iSingleThreadMode: boolean;
    msgp: boolean;		(* flag set if any messages pending *)
    inputReady: boolean;

(* various constant pointers *)
    xhat,yhat,zhat,nilvect: vectorp;
    niltrans: transp;
    gpark, rpark: transp;		(* arm park positions *)

(* various device & variable pointers *)
    speedfactor: enventryp;
    garm: framep;

{ Externally defined routines from elsewhere: }

	(* from FREE *)  
procedure freStrng(st: strngp);					external;

	(* From ALLOC *)
function newNode: nodep;					external;
procedure relNode(n: nodep);					external;
function newToken: tokenp;					external;
procedure relToken(n: tokenp);					external;
function newIdent: identp;					external;
function newStrng: strngp;					external;

	(* From EAUX1A *)
function hash(ch: ascii): integer;				external;
function upperCase(c: ascii): ascii;				external;
function resLookup(str,len: integer): reswordp;			external;
function idLookup(str,len: integer): identp;			external;
function makeUVar(vartype: datatypes; vid: identp): varidefp;	external;
function varLookup(id: identp): varidefp;			external;

	(* From EAUX1B *)
function copyExpr(n: nodep; lcp: boolean): nodep;		external;

	(* From EAUX1C *)
procedure errPrnt;						external;
function matchdim(d1,d2: nodep; exactp: boolean): boolean;	external;
function getdim(n: nodep; var d: nodep): nodep;			external;

	(* From EAUX2D *)
procedure readLine;						external;

	(* From PP *)
procedure ppLine; 						external;
procedure ppOutNow; 						external;
procedure ppChar(ch: ascii); 					external;
procedure pp5(ch: c5str; length: integer); 			external;
procedure pp10(ch: cstring; length: integer); 			external;
procedure pp10L(ch: cstring; length: integer);			external;
procedure pp20(ch: c20str; length: integer); 			external;
procedure pp20L(ch: c20str; length: integer); 			external;
procedure ppInt(i: integer); 					external;
procedure ppReal(r: real); 					external;
procedure ppStrng(length: integer; s: strngp); 			external;
procedure ppDtype(d: datatypes);				external;
procedure ppDelChar; 						external;

(* Token routines: copyToken, getToken *)

function copyToken: tokenp; external;	(* aux function used by getToken & elsewhere *)
function copyToken;
 var t: tokenp;
 begin
 t := newToken;			(* get a new token *)
  with curToken do		(* copy the token's fields from curToken *)
   begin
   t↑.next := next;
   t↑.ttype := ttype;
   if ttype = constype then t↑.cons := copyExpr(cons,true)
    else
     begin
     {$NORANGECHECK - cancels the subrange assignment check capability}
     t↑.rtype := rtype;
     t↑.len := len;		(* this should work ... *)
     t↑.str := str;
     {$RANGECHECK - Turns back on the subrange assignment check capability}
     end;
   end;
 copyToken := t;
 end;

procedure getToken; external;
procedure getToken;
 var b,bp: boolean; v,vp: varidefp; t,tp: tokenp; n: nodep;
     i,j,l: integer; r,rf: real; sp: statementp;
     ch,chp: ascii; res: reswordp; id: identp; st: strngp;

 procedure addChar(ch: ascii; var s: strngp; var j: integer);
  begin
  if j < 10 then j := j + 1
    else begin j := 1; s↑.next := newStrng; s := s↑.next; s↑.next := nil end;
  s↑.ch[j] := ch;
  end;

 procedure upToken(t: tokenp);
  begin
  if t <> nil then
   with t↑ do		(* copy the token's fields into curToken *)
    begin
    curToken.next := next;
    curToken.ttype := ttype;
    if ttype = constype then curToken.cons := copyExpr(cons,true)
     else
      begin
     {$NORANGECHECK - cancels the subrange assignment check capability}
      curToken.rtype := rtype;
      curToken.len := len;		(* this should work ... *)
      curToken.str := str;
     {$RANGECHECK - Turns back on the subrange assignment check capability}
      end;
    end;
  end;

 begin
 if backup and flushcomments and (curToken.ttype = comnttype) then
   begin		(* flush any comments we weren't ever supposed to see *)
   backup := false;
   freStrng(curToken.str);
   end;
 if backUp then backUp := false		(* use current token *)
  else if macrodepth > 0 then
   begin		(* get next token in macro *)
   if curToken.next = nil then
     begin			(* end of current macro - pop up a level *)
     v := curmacstack[macrodepth];	(* definition for current macro *)
     if v <> nil then
      if v↑.vtype = mactype then v := v↑.mdef↑.mpars	(* args for macro *)
       else v := nil;					(* no args *)
     while v <> nil do			(* need to release old tokens *)
      begin
      t := v↑.marg;
      while t <> nil do begin tp := t↑.next; relToken(t); t := tp end;
      v := v↑.next;
      end;
     curToken.next := macrostack[macrodepth];	(* pop old token *)
     macrodepth := macrodepth - 1;
     getToken;  			(* try again *)
     end
    else upToken(curToken.next);	(* otherwise just copy the next token *)
   end
  else if (curChar > maxChar) and not fParse then
   begin				(* that's it - end of line *)
   with curToken do
    begin
    ttype := delimtype;
    ch := chr(15B);
    end;
   endOfLine := true;
   end
  else
   begin				(* scan line for next token *)
   if curChar > maxChar then readline;
   while not endOfLine and
	((listing[curchar] = ' ') or (listing[curchar] = chr(11B))) do (* skip blanks *)
    if curchar < maxchar then curchar := curchar + 1
     else if fParse then readline else endOfLine := true;
   ch := listing[curchar];		(* first char of next token *)
   if (('A' <= ch) and (ch <= 'Z')) or (ch = chr(137B)) or	(* A..Z,_ *)
	((chr(141B) <= ch) and (ch <= chr(172B))) then		(* a..z *)
     begin			(* identifier or reserved word *)
     l := curchar;
     repeat
      l := l + 1;
      ch := listing[l];
     until not ((('0' <= ch) and (ch <= '9')) or (('A' <= ch) and (ch <= 'Z'))
	     or ((chr(141B) <= ch) and (ch <= chr(172B))) or (ch = chr(137B)));
     l := l - curchar;			(* length of string *)
     res := resLookup(curchar,l);
     if res <> nil then
       begin
       with curToken do		(* it's a reserved word *)
	begin
       {$NORANGECHECK - cancels the subrange assignment check capability}
	ttype := reswdtype;
	rtype := res↑.rtype;
	stmnt := res↑.stmnt;		(* copy whatever type it really is *)
       {$RANGECHECK - Turns back on the subrange assignment check capability}
	end;				(*  all fields are same length here *)
       if (res↑.rtype = stmnttype) and (res↑.stmnt = commenttype) then
	 begin				(* read comment *)
	 if not flushcomments then
	  begin
	  curToken.ttype := comnttype;
	  st := newStrng;
	  st↑.next := nil;
	  curToken.str := st;
	  j := 0;
	  l := 0;
	  end;
	 repeat
	  ch := listing[curchar];
	  if not flushcomments then
	   begin
	   addChar(ch,st,j);
	   l := l + 1;
	   end;
	  if (curchar < maxchar) or (ch = ';') then curchar := curchar + 1
	   else if fParse then
	    begin
	    readLine;
	    if not flushcomments then
	     begin
	     addChar(chr(15B),st,j);	    (* append a crlf *)
	     addChar(chr(12B),st,j);
	     l := l + 2;
	     end
	    end
	   else
	    begin
	    endOfLine := true;
	    if not flushcomments then
	     begin
	     addChar(';',st,j);		    (* end the comment *)
	     l := l + 1;
	     end;
	    end;
	 until endOfLine or eofError or (ch = ';');
	 curToken.len := l;
	 if eofError then
	   begin
	   pp20L('***  while searching',20); pp20(' for end of comment ',19);
	   ppLine;
	   end
	  else if flushcomments then getToken;	(* return a real token *)
	 end
	else curchar := curchar + l;
       end
      else
       begin
       curToken.ttype := identtype;	(* it's an identifier then *)
       id := idLookup(curchar,l);	(* see if it's already been defined *)
       if id = nil then			(*  need to define it *)
	 begin
	 id := newIdent;
	 st := newStrng;
	 st↑.next := nil;
	 with id↑ do
	  begin
	  name := st;
	  length := l;
	  predefined := nil;
	  i := hash(listing[curchar]);	(* find proper bucket *)
	  next := idents[i];		(* link us onto list of identifiers *)
	  idents[i] := id;
	  end;
	 j := 0;		(* now make a copy of the identifier's name *)
	 for i := curchar to curchar + l - 1 do
	  addChar(uppercase(listing[i]),st,j);
	 for i := j + 1 to 10 do st↑.ch[i] := ' ';	(* for completeness... *)
	 end;
       curchar := curchar + l;
       if (listing[curchar] <> ':') or (listing[curchar+1] = '=') then
	 curToken.id := id   (* we'll worry if it's a variable or constant later *)
	else
	 begin					(* looks like it's a label *)
	 curchar := curchar + 1;			(* skip over the ':' *)
	 v := varLookup(id);
	 if v = nil then
	   begin					(* undeclared label - be nice *)
	   pp20L(' Undeclared identifi',20); pp20('er defined to be a l',20);
	   pp5('abel.',5); errPrnt;
	   v := makeUVar(labeltype,id);
	   v↑.s := nil;
	   end
	  else if v↑.vtype <> labeltype then
	   begin					(* same name as existing variable *)
	   pp20L(' Previously defined ',20); pp20('variable used as a l',20);
	   pp10('abel name.',10); errPrnt;
	   end
	  else if v↑.s <> nil then		(* multiply defined label *)
	   begin
	   pp20L(' Multiply defined la',20); pp5('bel. ',4); errPrnt;
	   end;
	 if (v↑.vtype = labeltype) and (v↑.s = nil) then
	   begin					(* it's a good label *)
	   curToken.ttype := labeldeftype;
	   curToken.lab := v;
	   end
	  else getToken;		(* bad - ignore it & get a good token *)
	 end
       end
     end
    else if (('0' <= ch) and (ch <= '9'))		(* number *)
	  or ((ch = '.') and
	      ('0'<= listing[curchar+1]) and (listing[curchar+1] <= '9')) then
     begin
     r := 0;
     while ('0' <= ch) and (ch <= '9') do
      begin
      r := 10 * r + (ord(ch) - ord('0'));
      curchar := curchar + 1;
      ch := listing[curchar];
      end;
     if ch = '.' then			(* read in fraction part *)
      begin
      curchar := curchar + 1;		(* skip over '.' *)
      ch := listing[curchar];
      rf := 1;
      while ('0' <= ch) and (ch <= '9') do
       begin
       rf := rf * 10.0;
       r := r + (ord(ch) - ord('0')) / rf;
       curchar := curchar + 1;
       ch := listing[curchar];
       end;
      end;
     n := newNode;
     n↑.ntype := leafnode;
     n↑.ltype := svaltype;
     n↑.s := r;
     curToken.ttype := constype;
     curToken.cons := n;
     end
    else if ch = '"' then			(* string *)
     begin
     st := newStrng;
     st↑.next := nil;
     n := newNode;
     n↑.ntype := leafnode;
     n↑.ltype := strngtype;
     n↑.str := st;
     curToken.ttype := constype;
     curToken.cons := n;
     l := 0;
     j := 0;
     repeat
      if curchar < maxchar then curchar := curchar + 1
       else if fParse then
	begin
	readLine;
	addChar(chr(15B),st,j);			(* append a crlf *)
	addChar(chr(12B),st,j);
	l := l + 2;
	end
       else
	begin
	endOfLine := true;
	addChar('"',st,j);			(* end the string *)
	l := l + 1;
	end;
      ch := listing[curchar];
      b := (ch = '"');
      if b and (curchar < maxchar) then
	if listing[curchar+1] = '"' then
	 begin curchar := curchar + 1; b := false end;
      if not b then
	begin
	addChar(listing[curchar],st,j);
	l := l + 1;
	end;
     until endOfLine or eofError or b;
     if eofError then
       begin
       pp20L('***  while searching',20); pp20(' for end of string  ',18);
       ppLine;
       end;
     n↑.length := l;
     curchar := curchar + 1;
     end
    else if (ch = chr(173B)) or		(* chr(173B) = '{' *)
	 (((ch = '(') or (ch = '/')) and (listing[curchar+1] = '*')) then
     begin				(* it's a comment *)
     if not flushcomments then
      begin
      curToken.ttype := comnttype;
      st := newStrng;
      st↑.next := nil;
      curToken.str := st;
      end;
     j := 0;
     l := 0;
     repeat
      ch := listing[curchar];
      if not flushcomments then
       begin
       addChar(ch,st,j);
       l := l + 1;
       end;
      b := ch='}';
      if ((ch=')') or (ch='/')) and (1 < curchar) then
	b := listing[curchar-1]='*';
      if (curchar < maxchar) or b then curchar := curchar + 1
       else if fParse then
	begin
	readLine;
	addChar(chr(15B),st,j);			(* append a crlf *)
	addChar(chr(12B),st,j);
	l := l + 2;
	end
       else
	begin
	endOfLine := true;
	if not flushcomments then
	 begin
	 addChar('*',st,j);			(* end the comment *)
	 addChar(')',st,j);
	 l := l + 2;
	 end;
	end;
     until endOfLine or eofError or b;
     curToken.len := l;
     if eofError then
       begin
       pp20L('***  while searching',20); pp20(' for end of comment ',19);
       ppLine;
       end
      else if flushcomments then getToken; (* return a real token *)
     end
    else			(* delimiter or operator *)
     begin
     chp := listing[curchar+1];
     if ((ch = ':') and (chp = '=')) or				(* := *)
	((ch = '-') and (chp = '>')) or				(* -> *)
	(((ch = '<') or (ch = '>')) and (chp = '=')) or		(* <= >= *)
	((ch = '=') and ((chp = '<') or (chp = '>'))) or	(* =< => *)
	((ch = '<') and (chp = '>')) then l := 2		(* <> *)
      else l := 1;
     res := resLookup(curchar,l);
     with curToken do
      if res <> nil then		(* it's an operator *)
	begin
	ttype := reswdtype;
	rtype := res↑.rtype;
	op := res↑.op;
	end
       else				(* it's a delimiter *)
	begin
	ttype := delimtype;
	if endOfLine then ch := chr(15B) else ch := listing[curchar];
	end;
     curchar := curchar + l;
     end;
   end;
 b := expandmacros;
 while b and ((curToken.ttype = identtype) or (curToken.ttype = macpartype)) do
  begin				(* see if we need to expand a macro *)
  with curToken do
   if ttype = identtype then v := varLookup(id) else v := mpar;
  if v = nil then b := false
   else if v↑.vtype = macargtype then
    begin
    macrodepth := macrodepth + 1;
    macrostack[macrodepth] := curToken.next;	(* push current token *)
    curmacstack[macrodepth] := v;		(* no arguments here *)
    upToken(v↑.marg);				(* actual macro arg *)
    end
   else if v↑.vtype = mactype then
    begin
    vp := v↑.mdef↑.mpars;			(* get parameter list *)
    if vp <> nil then				(* bind macro parameters *)
     begin
     getToken;					(* look for opening '(' *)
     if (curToken.ttype <> delimtype) or (curToken.ch <> '(') then
       begin					(* didn't find opening '(' *)
       backUp := true;
       pp20L(' *** Macro arguments',20); pp20(' missing opening "("',20);
       pp20(' - good luck!       ',13); errPrnt;
       end;
     while vp <> nil do
      begin
      getToken;			(* see if it's a simple or \...\ arg *)
      if (curToken.ttype = delimtype) and (curToken.ch = '\') then
	begin
	t := nil;
	repeat
	 getToken;			(* scan the argument *)
	 bp := (curToken.ttype = delimtype) and (curToken.ch = '\');
	 if not bp then
	  if t = nil then begin t := copyToken; tp := t end
	   else begin tp↑.next := copyToken; tp := tp↑.next end;
	until bp;
	end
       else t := copyToken;
      vp↑.marg := t;
      vp := vp↑.next;
      getToken;		(* now get separating ',' or closing ')' *)
      if vp <> nil then			(* look for separating comma *)
	if (curToken.ttype <> delimtype) or (curToken.ch <> ',') then
	 begin
	 backUp := true;
	 pp20L(' *** Macro args not ',20); pp20('separated by "," - g',20);
	 pp10('ood luck! ',9); errPrnt;
	 end;
      end;
     if (curToken.ttype <> delimtype) or (curToken.ch <> ')') then
       begin
       backUp := true;			(* back up so we'll reparse last token *)
       pp20L(' *** Macro arguments',20); pp20(' missing closing ")"',20);
       pp20(' - good luck!       ',13); errPrnt;
       end;
     end;
    macrodepth := macrodepth + 1;
    macrostack[macrodepth] := curToken.next;	(* push current token *)
    curmacstack[macrodepth] := v;		(* save pointer to macro name *)
    upToken(v↑.mdef↑.macdef);			(* expand macro *)
    end
   else b := false;
  end;
 if fParse and eofError then endOfLine := true;
 end;

(* aux routines for parsing expressions: dimCheck, getDelim *)

procedure dimCheck(n,d: nodep); external;	(* expr n should be of dimension d *)
procedure dimCheck;
 var dp: nodep;
 begin
 dp := nil;
 if not matchDim(getDim(n,dp),d,checkDims) then	(* does dimension match ok? *)
  begin
  pp20L(' Dimensions don''t ma',20); pp5('tch  ',3);
  errPrnt;
  end;
 relNode(dp);
 end;

 procedure getDelim(char: ascii); external;
 procedure getDelim;
  begin
  getToken;			(* look for the char *)
  with curToken do
   if (ttype <> delimtype) or (ch <> char) then
    begin
    backup := true;
    pp10L(' Need a " ',9); ppChar(char); pp10('" here.   ',7);
    errPrnt;
    end;
  end;