ceriel 36 лет назад
Родитель
Сommit
67668218c8
4 измененных файлов с 3966 добавлено и 0 удалено
  1. 3 0
      lang/a68s/cpem/.distr
  2. 39 0
      lang/a68s/cpem/Makefile
  3. 103 0
      lang/a68s/cpem/READ_ME
  4. 3821 0
      lang/a68s/cpem/cpem.p

+ 3 - 0
lang/a68s/cpem/.distr

@@ -0,0 +1,3 @@
+Makefile
+READ_ME
+cpem.p

+ 39 - 0
lang/a68s/cpem/Makefile

@@ -0,0 +1,39 @@
+# $Header$
+d=../../..
+h=$d/h
+
+# Use apc -m.... for cross-compilation.
+APC=apc
+# The call to acc has to produce an executable file
+# Add an -m parameter if needed.
+ACC=acc
+
+HEAD=$h/em_spec.h $h/em_pseu.h $h/em_mnem.h $h/em_mes.h $h/pc_size.h
+LDFLAG=-i
+
+all:            cpem
+
+cpem.out:       cpem.m
+		apc -mint --t -o cpem.out cpem.m
+
+cpem:           cpem.m
+		$(APC) $(LDFLAG) -o cpem cpem.m
+
+# cpem.m is system dependent and may NOT be distributed
+cpem.m:         cpem.p $(HEAD)
+		-rm -f cpem.m
+		-if $(APC) -I$h -DCHL -O -c.m cpem.p ; then :; else \
+			$(ACC) -o move ../../pc/pem/move.c ; move ; rm -f move move.[oskm] ; \
+		fi
+
+clean:
+		-rm -f *.[os] *.old
+
+pr:
+		@pr cpem.p
+
+xref:
+		xref cpem.p^pr -h "XREF PEM.P"
+
+opr:
+		make pr ^ opr

+ 103 - 0
lang/a68s/cpem/READ_ME

@@ -0,0 +1,103 @@
+this modset adds special facilities to the pascal compiler for 
+compiling the a68s compiler and run-time system.  the facilities 
+added are sufficient for their purpose, but no checks for mis-use are
+made, and anyone using them for other purposes does so at his own risk.
+
+******************************************* 
+
+******************************************** 
+
+these mods introduce the following built-in procedures and functions:
+
+   procedure setstktop(size, a, v: integer); 
+      sets the word in (b5-1-a) (?) to the value v. size must be >0. 
+   procedure enew(p: nilptr; size: integer); 
+      as new, but exactly size words are obtained. 
+   procedure edispose(p: nilptr; size: integer);
+      as dispose, but exactly size words are returned.
+   procedure moveleft(from, to: nilptr; size: integer);
+      moves a block of 'size' words starting at 'from' to 'to'.
+      copying starts at the leftmost word.
+      size must be a multiple of word size.
+   function getstktop(size, a: integer): integer;
+      returns the value held in (b5-1-a)(?). size must be >0.
+   function asptr(v: integer): nilptr;
+      returns the value of v as if it were a pointer. the function
+      asptr may be used in any context in a pascal program where nil
+      would be acceptable (in algol 68 terminology - in any strong
+      context). note that the language already provides the function
+      'ord' to perform the converse operation of 'asptr'.
+   function incptr(p: nilptr; v: integer): nilptr;
+     increments the pointer p by v, and returns the result.
+
+*********************************************
+
+The following additional compiler options are provided
+
+	e:      all procedure names external (even inner ones) (-)
+	g:      global declarations compiled (+)
+		when compiling segments of procedures:
+		  g- implies that global declarations are merely repetitions
+		  (which had better be correct!) of declarations in some
+		  master segment.
+		when compiling main program:
+		  g- implies that such a master segment is being compiled.
+	w:      generate warnings as well as error messages (+)
+  
+  all the above options are translated to lower case, thus are case
+  independent. This applies to options in the source file and to those
+  passed via C_EM_PC.
+
+*********************************************
+
+----------------------------
+revision 2.10        
+date: 86/08/19 15:22:09;  author: dw;  state: Exp;  lines added/del: 2/1
+This lets 'getstktop' know about reals so it does not try to convert what
+is already a real to a real and get it wrong.
+----------------------------
+revision 2.9        
+date: 86/08/13 12:03:49;  author: dw;  state: Exp;  lines added/del: 3/2
+more of 2.8, label now after goto descriptor 
+----------------------------
+revision 2.8        
+date: 86/08/11 19:57:32;  author: dw;  state: Exp;  lines added/del: 49/0
+This makes labels that are jumped to non-locally have a global label 
+associated with them. The labels are of the form _xxxnnn where xxx is the
+number of the label & nnn is the name of the routine.
+----------------------------
+revision 2.7        
+date: 86/07/17 19:42:29;  author: dw;  state: Exp;  lines added/del: 2/1
+This fixes getstktop. It now uses 'ads' rather than 'adu'. The changes have
+been made in 'call'.
+----------------------------
+revision 2.6        
+date: 86/07/17 19:30:30;  author: dw;  state: Exp;  lines added/del: 15/0
+This causes all USER procedural identifiers ( <PRO> ) to be in upper case
+Modifacation to 'argident'. (m_a_i_n) is left in lower case for 'ld'.
+----------------------------
+revision 2.5        
+date: 86/07/17 19:25:10;  author: dw;  state: Exp;  lines added/del: 7/1
+This forces the compiler to take note of where an EXTERN procedure is
+declared and make it STATICALLY be there.
+----------------------------
+revision 2.4        
+date: 86/07/17 19:22:39;  author: dw;  state: Exp;  lines added/del: 13/1
+'r' option sets the effective upperbound as high as is possible
+----------------------------
+revision 2.3        
+date: 86/07/17 19:20:20;  author: dw;  state: Exp;  lines added/del: 19/1
+This implements incptr.
+----------------------------
+revision 2.2        
+date: 86/03/14 20:35:27;  author: dw;  state: Exp;  lines added/del: 39/3
+This should cure the problem of the compiler not allowing output to the
+file OUTPUT from a seperatly compiled segment. It does this by always 
+setting up INPUT and OUTPUT.
+----------------------------
+revision 2.1        
+date: 86/03/03 21:53:06;  author: dw;  state: Exp;  lines added/del: 278/26
+This is the alternate form of the compiler as modified by CHL
+It offers several extentions to the existing compiler needed to compile
+the ALGOL68S compiler.
+=============================================================================

+ 3821 - 0
lang/a68s/cpem/cpem.p

@@ -0,0 +1,3821 @@
+#include        <em_spec.h>
+#include        <em_pseu.h>
+#include	<em_mnem.h>
+#include	<em_mes.h>
+#include	<em_reg.h>
+#include	<pc_size.h>
+
+{
+  (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ 
+           This product is part of the Amsterdam Compiler Kit.
+ 
+  Permission to use, sell, duplicate or disclose this software must be
+  obtained in writing. Requests for such permissions may be sent to
+ 
+       Dr. Andrew S. Tanenbaum
+       Wiskundig Seminarium
+       Vrije Universiteit
+       Postbox 7161
+       1007 MC Amsterdam
+       The Netherlands
+ 
+}
+
+{if next line is included the compiler itself is written in standard pascal}
+{#define        STANDARD        1}
+{if next line is included the compiler contains the extra features needed
+ for ALGOL 68S}
+#define         CHL             1
+
+{if next line is included, the compiler won't generate static exchanges}
+{#define	NO_EXC	1}
+
+{Author:        Johan Stevenson                 Version:        32}
+{$l- : no source line numbers}
+{$r- : no subrange checking}
+{$a- : no assertion checking}
+#ifdef STANDARD
+{$s+ : test conformancy to standard}
+#endif
+
+program pem(input,em,errors,output);
+{/*
+   This Pascal compiler produces EM code as described in
+   - A.S.Tanenbaum, J.W.Stevenson & H. van Staveren,
+	"Description of a machine architecture for use with
+	 block structured languages" Informatika rapport 81.
+  NOTE: this version is modified to produce the modified EM code of
+	januari 1981. it is not possible, using this compiler, to
+	generate code for machines with 1 byte wordsize.
+  NOTE: this version is modified by Kees Visser in such a way that
+	the compiler can now run on 2 and 4 byte machines. It is also
+	able to generate em-code for a 2 bytes machine while running
+	on a 4-bytes machine. Cross-compilation from a 2 bytes to a
+	four bytes machine is also possible with the following
+	exception: large integers that don't fit in an integer of 
+	the compiler are treated like longs and are thus not allowed
+	in types.
+
+  A description of Pascal is given in
+   - K.Jensen & N.Wirth, "PASCAL user manual and report", Springer-Verlag.
+  Several options may be given in the normal pascal way. Moreover,
+  a positive number may be used instead of + and -. The options are:
+	a:      interpret assertions (+)
+	c:      C-type strings allowed (-)
+	d:      type long may be used (-)
+	i:      controls the number of elements in integer sets
+			default: (wordsize in bits)
+	l:      insert code to keep track of source lines (+)
+	o:      optimize (+)
+	r:      check subranges (+)
+	s:      accept only standard pascal programs (-)
+	t:      trace procedure entry and exit (-)
+	u:      treat '_' as letter (-)
+#ifdef  CHL
+	e:      all procedure names external (even inner ones) (-)
+	g:      global declarations compiled (+)
+		when compiling segments of procedures:
+		  g- implies that global declarations are merely repetitions
+		  (which had better be correct!) of declarations in some master
+		  segment.
+		when compiling main program:
+		  g- implies that such a master segment is being compiled.
+	w:      generate warnings as well as error messages (+)
+  
+  all the above options are translated to lower case, thus are case
+  independent. This applies to options in the source file and to those
+  passed via C_EM_PC.
+#endif
+*/}
+{===================================================================}
+#ifdef STANDARD
+label 9999;
+#endif
+
+const
+{fundamental constants}
+  MB1 = 7;
+  NB1 = 8;
+  MI1 = 127;
+  NI1 = 128;
+  MI2 = 32767;
+  MU1 = 255;
+  NU1 = 256;
+
+{string constants}
+  imax = 10;
+#ifdef CHL
+  max2bytes   = '0000032768';
+  max4bytes   = '2147483648';
+#else
+  max2bytes   = '0000032767';
+  max4bytes   = '2147483647';
+#endif
+
+#if EM_WSIZE == 4
+  {this can only be compiled with a compiler that has integer size 4}
+  MU2 = 65535;
+  NU2 = 65536;
+
+  {characteristics of the machine on which the compiler will run}
+  {wordsize and integer size are 4}
+  MI = 2147483647;
+  maxcompintstring = max4bytes;
+#endif
+#if EM_WSIZE == 2
+  MU2 = 0;	{not used}
+  NU2 = 0;	{not used}
+
+  MI = MI2;
+  maxcompintstring = max2bytes;
+#endif
+#if EM_WSIZE != 2 && EM_WSIZE != 4
+Something wrong here!
+#endif
+
+{maximal indices}
+  idmax         = 8;
+  fnmax         = 14;
+  smax          = 72;
+
+{opt values}
+  off           = 0;
+  on            = 1;
+
+{for push and pop: }
+  global        = false;
+  local         = true;
+
+{for sizeof and posaddr: }
+  wordmult      = false;
+  wordpart      = true;
+
+{ASCII characters}
+  ascht         = 9;
+  ascnl         = 10;
+  ascvt         = 11;
+  ascff         = 12;
+  asccr         = 13;
+
+{miscellaneous}
+  maxcharord    = 127;          {maximal ordinal number of chars}
+  maxargc       = 13;           {maximal index in argv}
+  rwlim         = 34;           {number of reserved words}
+  spaces        = '        ';
+
+{-------------------------------------------------------------------}
+type
+{scalar types}
+  symbol=       (comma,semicolon,colon1,colon2,notsy,lbrack,ident,
+		 intcst,charcst,realcst,longcst,stringcst,nilcst,minsy,
+		 plussy,lparent,arrow,arraysy,recordsy,setsy,filesy,
+		 packedsy,progsy,labelsy,constsy,typesy,varsy,procsy,
+		 funcsy,beginsy,gotosy,ifsy,whilesy,repeatsy,forsy,
+		 withsy,casesy,becomes,starsy,divsy,modsy,slashsy,
+		 andsy,orsy,eqsy,nesy,gtsy,gesy,ltsy,
+		 lesy,insy,endsy,elsesy,untilsy,ofsy,dosy,
+		 downtosy,tosy,thensy,rbrack,rparent,period
+		);                      {the order is important}
+  chartype=     (lower,upper,digit,layout,tabch,
+		   quotech,dquotech,colonch,periodch,lessch,
+		   greaterch,lparentch,lbracech,
+						{different entries}
+		 rparentch,lbrackch,rbrackch,commach,semich,arrowch,
+		   plusch,minch,slash,star,equal,
+						{also symbols}
+		 others
+		);
+  standpf=      (pread,preadln,pwrite,pwriteln,pput,pget,
+		 preset,prewrite,pnew,pdispose,ppack,punpack,
+#ifdef  CHL
+		 penew,pedispose,
+#endif
+		 pmark,prelease,ppage,
+#ifdef  CHL
+		 psetstktop,pmoveleft,
+#endif
+		 phalt,
+						{all procedures}
+		 feof,feoln,fabs,fsqr,ford,fchr,fpred,fsucc,fodd,
+#ifdef  CHL
+		 fasptr,fincptr,fgetstktop,
+#endif
+		 ftrunc,fround,fsin,fcos,fexp,fsqt,flog,fatn
+						{all functions}
+		);                      {the order is important}
+  libmnem=      (ELN ,EFL ,CLS ,WDW ,           {input and output}
+		 OPN ,GETX,RDI ,RDC ,RDR ,RDL ,RLN ,
+						{on inputfiles}
+		 CRE ,PUTX,WRI ,WSI ,WRC ,WSC ,WRS ,WSS ,WRB ,
+		 WSB ,WRR ,WSR ,WRL, WSL, WRF ,WRZ ,WSZ ,WLN ,PAG ,
+				{on outputfiles, order important}
+		 ABR ,RND ,SINX,COSX,EXPX,SQT ,LOG ,ATN ,
+						{floating point}
+		 ABI ,ABL ,BCP ,BTS ,NEWX,SAV ,RST ,INI ,HLT ,
+		 ASS ,GTO ,PAC ,UNP, DIS, ASZ, MDI, MDL
+						{miscellaneous}
+		);
+  structform=   (scalar,subrange,pointer,power,files,arrays,carray,
+		 records,variant,tag);          {order important}
+  structflag=   (spack,withfile);
+  identflag=    (refer,used,assigned,noreg,loopvar,samesect);
+  idclass=      (types,konst,vars,field,carrbnd,proc,func);
+  kindofpf=     (standard,formal,actual,extern,varargs,forward);
+  where=        (blck,rec,wrec);
+  attrkind=     (cst,fixed,pfixed,loaded,ploaded,indexed);
+  twostruct=    (eq,subeq,ir,ri,il,li,lr,rl,es,se,noteq);  {order important}
+
+{subrange types}
+  rwrange=      0..rwlim;
+  byte=         0..MU1;
+
+{pointer types}
+  sp=   ^structure;
+  ip=   ^identifier;
+  lp=   ^labl;
+  bp=   ^blockinfo;
+  np=   ^nameinfo;
+#ifdef NO_EXC
+  mp=	^mmark;
+  op=	^outrec;
+#endif NO_EXC
+
+{set types}
+  sos=          set of symbol;
+  setofids=     set of idclass;
+  formset=      set of structform;
+  sflagset=     set of structflag;
+  iflagset=     set of identflag;
+
+{array types}
+  idarr=packed array[1..idmax] of char;
+  fnarr=packed array[1..fnmax] of char;
+
+{record types}
+  position=record               {the addr info of certain variable}
+    ad:integer;                 {for locals it is the byte offset}
+    lv:integer;                 {the level of the beast}
+  end;
+
+{records of type attr are used to remember qualities of
+  expression parts to delay the loading of them.
+  Reasons to delay the loading of one word constants:
+	- bound checking
+	- set building.
+  Reasons to delay the loading of direct accessible objects:
+	- efficient handling of read/write
+	- efficient handling of the with statement.
+}
+  attr=record
+    asp:sp;                             {type of expression}
+    packbit:boolean;                    {true for part of packed structure}
+    ak:attrkind;                        {access method}
+    pos:position;                       {lv and ad}
+    {If ak=cst then the value is stored in ad}
+  end;
+
+  nameinfo=record               {one for each separate name space}
+    nlink:np;                   {one deeper}
+    fname:ip;                   {first name: root of tree}
+    case occur:where of
+      blck:();
+      rec: ();
+      wrec:(wa:attr)            {name space opened by with statement}
+  end;
+
+  blockinfo=record      {all info of the current procedure}
+    nextbp:bp;          {pointer to blockinfo of surrounding proc}
+    reglb:integer;      {data location counter (from begin of proc) }
+    minlb:integer;      {keeps track of minimum of reglb}
+    ilbno:integer;      {number of last local label}
+#ifdef  CHL
+    tip:ip;             {ip of current proc/func}
+#endif
+    forwcount:integer;  {number of not yet specified forward procs}
+    lchain:lp;          {first label: header of chain}
+  end;
+
+  structure=record
+    size:integer;                       {size of structure in bytes}
+    sflag:sflagset;                     {flag bits}
+    case form:structform of
+      scalar  :(scalno:integer;         {number of range descriptor}
+		fconst:ip               {names of constants}
+	       );
+      subrange:(min,max:integer;        {lower and upper bound}
+		rangetype:sp;           {type of bounds}
+		subrno:integer          {number of subr descriptor}
+	       );
+      pointer :(eltype:sp);             {type of pointed object}
+      power   :(elset:sp);              {type of set elements}
+      files   :(filtype:sp);            {type of file elements}
+      arrays,carray:
+	       (aeltype:sp;             {type of array elements}
+		inxtype:sp;             {type of array index}
+		arpos:position          {position of array descriptor}
+	       );
+      records :(fstfld:ip;              {points to first field}
+		tagsp:sp                {points to tag if present}
+	       );
+      variant :(varval:integer;         {tag value for this variant}
+		nxtvar:sp;              {next equilevel variant}
+		subtsp:sp               {points to tag for sub-case}
+	       );
+      tag     :(fstvar:sp;              {first variant of case}
+		tfldsp:sp               {type of tag}
+	       )
+  end;
+
+  identifier=record
+    idtype:sp;                          {type of identifier}
+    name:idarr;                         {name of identifier}
+    llink,rlink:ip;                     {see enterid,searchid}
+    next:ip;                            {used to make several chains}
+    iflag:iflagset;                     {several flag bits}
+    case klass:idclass of
+      types   :();
+      konst   :(value:integer);         {for integers the value is
+		  computed and stored in this field.
+		  For strings and reals an assembler constant is
+		  defined labeled '.1', '.2', ...  This '.' number is then
+		  stored in value. For reals value may be negated to
+		  indicate that the opposite of the assembler constant
+		  is needed. }
+      vars    :(vpos:position);         {position of var}
+      field   :(foffset:integer);       {offset to begin of record}
+      carrbnd :();                      {idtype points to carray struct}
+      proc,func:
+	(case pfkind:kindofpf of
+	   standard:(key:standpf);      {identification}
+	   formal,actual,forward,extern,varargs:
+	     (pfpos:position;           {lv gives declaration level.
+			ad is relevant for formal pf s and for
+			functions (no conflict!!).
+			for functions: ad is the result address.
+			for formal pf s: ad is the address of the
+			descriptor }
+	      pfno:integer;             {unique pf number}
+	      maxlb:integer;		{bytes of parameters}
+	      parhead:ip                {head of parameter list}
+	     )
+	)
+  end;
+
+  labl=record
+    nextlp:lp;          {chain of labels}
+    seen:boolean;
+    labval:integer;     {label number given by the programmer}
+    labname:integer;    {label number given by the compiler}
+    labdlb:integer      {zero means only locally used,
+			  otherwise dlbno of label information}
+  end;
+
+#ifdef NO_EXC
+  outrec=record
+    next:op;		{chain of records}
+    bytes:array[1..16] of byte;
+    cnt:0..16;
+  end;
+
+  mmark=record
+    next:mp;		{chain of marks}
+    count,where:integer;
+  end;
+#endif NO_EXC
+{-------------------------------------------------------------------}
+var  {the most frequent used externals are declared first}
+  sy:symbol;            {last symbol}
+  a:attr;               {type,access method,position,value of expr}
+{returned by insym}
+  ch:char;              {last character}
+  chsy:chartype;        {type of ch, used by insym}
+  val:integer;          {if last symbol is an constant }
+  ix:integer;           {string length}
+  eol:boolean;          {true of current ch is a space, replacing a newline}
+  zerostring:boolean;   {true for strings in " "}
+  id:idarr;             {if last symbol is an identifier}
+{some counters}
+  lino:integer;         {line number on code file (1..n) }
+  dlbno:integer;        {number of last global number}
+#ifdef CHL
+  glbdata:integer;	{start of hol area}
+  holdone:boolean;	{set after genhol called}
+#endif
+  holeb:integer;        {size of hol-area}
+  level:integer;        {current static level}
+  argc:integer;         {index in argv}
+  lastpfno:integer;     {unique pf number counter}
+  copt:integer;         {C-type strings allowed if on}
+  dopt:integer;         {longs allowed if on}
+  iopt:integer;         {number of bits in sets with base integer}
+  sopt:integer;         {standard option}
+  srcchno:integer;      {column count for errors}
+  srclino:integer;      {source line number after preprocessing}
+  srcorig:integer;      {source line number before preprocessing}
+  fildlb:integer;       {label number of source string}
+{pointers pointing to standard types}
+  realptr,intptr,textptr,nullset,boolptr:sp;
+  charptr,nilptr,zeroptr,procptr,longptr:sp;
+{flags}
+  giveline:boolean;     {give source line number at next statement}
+  including:boolean;    {no LINs for included code}
+  eofexpected:boolean;  {quit without error if true (nextch) }
+  main:boolean;         {complete programme or a module}
+  intypedec:boolean;    {true if nested in typedefinition}
+  fltused:boolean;      {true if floating point instructions are used}
+  seconddot:boolean;    {indicates the second dot of '..'}
+#ifdef CHL
+  ioaddressfixed:boolean; {indicates if argv[0..1].ad set up}
+#endif
+{pointers}
+  fwptr:ip;             {head of chain of forward reference pointers}
+  progp:ip;             {program identifier}
+  currproc:ip;          {current procedure/function ip (see selector)}
+  top:np;               {pointer to the most recent name space}
+  lastnp:np;            {pointer to nameinfo of last searched ident }
+{records}
+  b:blockinfo;          {all info to be stacked at pfdeclaration}
+  fa:attr;              {attr for current file name}
+{arrays}
+  sizes:array[0 .. sz_last] of integer;
+  maxintstring,maxlongstring:packed array[1..imax] of char;
+  strbuf:array[1..smax] of char;
+  rw:array[rwrange] of idarr;
+			{reserved words}
+  frw:array[0..idmax] of integer;
+			{indices in rw}
+  rsy:array[rwrange] of symbol;
+			{symbol for reserved words}
+  cs:array[char] of chartype;
+			{chartype of a character}
+  csy:array[rparentch..equal] of symbol;
+			{symbol for single character symbols}
+  lmn:array[libmnem] of packed array[1..4] of char;
+			{mnemonics of pascal library routines}
+  opt:array['a'..'z'] of integer;
+  forceopt:array['a'..'z'] of boolean;
+			{26 different options}
+  undefip:array[idclass] of ip;
+			{used in searchid}
+  iop:array[boolean] of ip;
+			{false:standard input, true:standard output}
+  argv:array[0..maxargc] of
+	 record name:idarr; ad:integer end;
+			{save here the external heading names}
+{files}
+   em:file of byte;      {the EM code}
+  errors:text;          {the compilation errors}
+  source:fnarr;
+#ifdef NO_EXC
+  ohead: op;	{head of outrec list}
+  mhead: mp;	{head of marks list}
+  bcnt: integer;
+#define newmark setmark
+#define relmark(xx) freemark(xx)
+#else not NO_EXC
+#define newmark lino
+#define relmark(xx)
+#endif NO_EXC
+
+{===================================================================}
+
+procedure initpos(var p:position);
+begin p.lv:=level; p.ad:=0; end;
+
+procedure inita(fsp:sp; fad:integer);
+begin with a do begin
+  asp:=fsp; packbit:=false; ak:=fixed; pos.ad:=fad; pos.lv:=level;
+end end;
+
+function newip(kl:idclass; n:idarr; idt:sp; nxt:ip):ip;
+var p:ip; f:iflagset;
+begin f:=[];
+  case kl of
+    types,carrbnd:  {similar structure}
+      new(p,types);
+    konst:
+      begin new(p,konst); p^.value:=0 end;
+    vars:
+      begin new(p,vars); f:=[used,assigned]; initpos(p^.vpos) end;
+    field:
+      begin new(p,field); p^.foffset:=0 end;
+    proc,func:  {same structure}
+      begin new(p,proc,actual); p^.pfkind:=actual;
+	initpos(p^.pfpos); p^.pfno:=0; p^.maxlb:=0; p^.parhead:=nil;
+      end
+  end;
+  p^.name:=n; p^.klass:=kl; p^.idtype:=idt; p^.next:=nxt;
+  p^.llink:=nil; p^.rlink:=nil; p^.iflag:=f; newip:=p
+end;
+
+function newsp(sf:structform; sz:integer):sp;
+var p:sp; sflag:sflagset;
+begin sflag:=[];
+  case sf of
+    scalar:
+      begin new(p,scalar); p^.scalno:=0; p^.fconst:=nil end;
+    subrange:
+      new(p,subrange);
+    pointer:
+      begin new(p,pointer); p^.eltype:=nil end;
+    power:
+      new(p,power);
+    files:
+      begin new(p,files); sflag:=[withfile] end;
+    arrays,carray:  {same structure}
+      new(p,arrays);
+    records:
+      new(p,records);
+    variant:
+      new(p,variant);
+    tag:
+      new(p,tag);
+  end;
+  p^.form:=sf; p^.size:=sz; p^.sflag:=sflag; newsp:=p;
+end;
+
+function sizeof(fsp:sp; partword:boolean):integer;
+var s:integer;
+begin if fsp=nil then s:=0 else s:=fsp^.size;
+  if s<>0 then
+    if partword and (s<sz_word) then
+      while sz_word mod s <> 0 do s:=s+1
+    else
+      while s mod sz_word <> 0 do s:=s+1;
+  sizeof:=s
+end;
+
+function formof(fsp:sp; forms:formset):boolean;
+begin if fsp=nil then formof:=false else formof:=fsp^.form in forms end;
+
+{===================================================================}
+
+#ifdef NO_EXC
+procedure newoutrec;
+var p:op;
+begin
+  new(p);
+  bcnt := bcnt+1;
+  with p^ do begin cnt := 0; next := ohead end;
+  ohead := p
+end;
+
+procedure put1(b:byte);
+begin
+  if mhead = nil then write(em,b)
+  else begin
+    if ohead^.cnt = 16 then newoutrec;
+    with ohead^ do
+      begin cnt := cnt + 1; bytes[cnt] := b end
+  end
+end;
+#else not NO_EXC
+procedure put1(b:byte);
+begin write(em,b) end;
+#endif NO_EXC
+
+procedure put2(i:integer);
+var i1,i2:byte;
+begin
+  if i<0 then
+    begin i:=-(i+1); i1:=MU1 - i mod NU1; i2:=MU1 - i div NU1 end
+  else
+    begin i1:=i mod NU1; i2:=i div NU1 end;
+  put1(i1); put1(i2)
+end;
+
+#if EM_WSIZE == 4
+procedure put4(i:integer);
+var i1,i2:integer;
+begin
+  if i<0 then
+    begin i:=-(i+1); i1:=MU2 - i mod NU2; i2:=MU2 - i div NU2 end
+  else
+    begin i1:=i mod NU2; i2:=i div NU2 end;
+  put1(i1 mod NU1); put1(i1 div NU1);
+  put1(i2 mod NU1); put1(i2 div NU1)
+end;
+#endif
+
+procedure argend;
+begin put1(sp_cend) end;
+
+procedure argcst(i:integer);
+begin
+  if (i >= -sp_zcst0) and (i < sp_ncst0-sp_zcst0) then
+    	 put1(i + sp_zcst0 + sp_fcst0)
+  else
+#if EM_WSIZE == 4
+	if (i >= -MI2-1) and (i <= MI2) then
+#endif
+    	 begin put1(sp_cst2); put2(i) end
+#if EM_WSIZE == 4
+  else   begin put1(sp_cst4); put4(i) end
+#endif
+end;
+
+procedure argnil;
+begin put1(sp_icon); argcst(sz_addr); argcst(1); put1(ord('0')) end;
+
+procedure argilb(i:integer);
+begin
+  if i<=MU1 then
+    begin put1(sp_ilb1); put1(i) end
+  else
+    begin put1(sp_ilb2); put2(i) end
+end;
+
+procedure argdlb(i:integer);
+begin
+  if i<=MU1 then
+    begin put1(sp_dlb1); put1(i) end
+  else
+    begin put1(sp_dlb2); put2(i) end
+end;
+
+procedure argident(var a:idarr);
+var i,j:integer;
+#ifdef CHL
+      k:integer;
+#endif
+begin i:=idmax;
+  while (a[i]=' ') and (i>1) do i:=i-1;
+  put1(sp_pnam); argcst(i);
+#ifdef CHL
+  if a='m_a_i_n ' then
+      for j:=1 to i do put1(ord(a[j]))
+  else
+      for j:=1 to i do
+      begin
+          k:=ord(a[j]);
+          if (k>96) and (k<123) then k:=k-32; (*translate to upper case*)
+          put1(k);
+      end;
+#else
+  for j:=1 to i do put1(ord(a[j]))
+#endif
+end;
+
+#ifdef CHL
+procedure dlbident(var a:idarr);
+var i,j,k:integer;
+begin i:=idmax;
+  while (a[i]=' ') and (i>1) do i:=i-1;
+  put1(sp_dnam); argcst (i);
+  for j:=1 to i do
+  begin
+      k:=ord(a[j]);
+      if (k>96) and (k<123) then k:=k-32; (*translate to upper case*)
+      put1(k);
+  end;
+end;
+#endif
+
+procedure genop(b:byte);
+begin put1(b); lino:=lino+1 end;
+
+procedure gencst(b:byte; i:integer);
+begin genop(b); argcst(i) end;
+
+#ifdef CHL
+procedure genarg(b:byte; i:integer);
+begin
+genop(b);
+put1(sp_doff); 
+argdlb(glbdata);
+argcst(i)
+end;
+#endif
+
+procedure genglb(b:byte; i:integer);
+begin
+#ifdef CHL
+  if opt['g']=off then genarg(b,i) else gencst(b,i);
+#else
+  gencst(b,i);
+#endif
+end;
+
+procedure gensp(m:libmnem; s:integer);
+var i:integer;
+begin genop(op_cal); put1(sp_pnam); argcst(4);
+  for i:=1 to 4 do put1(ord(lmn[m][i]));
+  gencst(op_asp,s)
+end;
+
+procedure genpnam(b:byte; fip:ip);
+var n:idarr; i,j:integer;
+begin
+#ifdef  CHL
+  if (fip^.pfpos.lv<=1) or (opt['e']=on) then
+#else
+  if fip^.pfpos.lv<=1 then
+#endif
+    n:=fip^.name
+  else
+    begin n:='_       '; j:=1; i:=fip^.pfno;
+      while i<>0 do
+	begin j:=j+1; n[j]:=chr(i mod 10 + ord('0')); i:=i div 10 end;
+    end;
+  genop(b); argident(n)
+end;
+
+#ifdef CHL
+procedure gengotonam(b:byte; fip:ip; l:integer);
+var index,count,val : integer;
+    n : idarr;
+begin
+   n:='_       ';
+   index:=2;
+   val:=l;
+   while val<>0 do
+   begin
+       n[index]:= chr(val mod 10 +ord('0'));
+       val:=val div 10;
+       index:=index+1;
+   end;
+   val:=1;
+   for count:=index to idmax do
+   begin
+       n[count]:=fip^.name[val];
+       val:=val+1;
+   end;
+   genop(b);
+   dlbident(n);
+   dlbident(n);      (* the last three instructions produce *)
+		     (* exa _xxxnnn *)
+		     (*_xxxnnn      *)
+		     (* where xxx is the number of the label supplied by the *)
+		     (*              programmer *)
+		     (* and   nnn is the name of the routine the label is in *)
+end;
+#endif
+
+procedure genasp(m:byte);
+begin gencst(m,sizeof(a.asp,wordmult)) end;
+
+procedure genlin;
+begin giveline:=false;
+  if opt['l']<>off then if main then gencst(op_lin,srcorig)
+end;
+
+procedure genreg(sz,ad,regval:integer);
+begin gencst(ps_mes,ms_reg);
+  argcst(ad); argcst(sz); argcst(regval); argend
+end;
+
+procedure laedlb(d:integer);
+begin genop(op_lae); argdlb(d) end;
+
+#ifdef NO_EXC
+procedure reloutrec;
+var i,j,k:integer;
+  q, r, p:op;
+  m : mp;
+begin p := ohead; q := p;
+  if mhead <> nil then
+    begin
+      m := mhead; while m^.next <> nil do m := m^.next;
+      k := (bcnt - m^.where) + 1
+    end
+  else begin k := 0; ohead := nil; bcnt := 0 end;
+  for i := 1 to k do begin q := p; p := p^.next end;
+  if q <> p then q^.next := nil;
+  if p <> nil then
+    begin r := nil;
+      while p <> nil do
+	begin q := p^.next; p^.next := r; r := p; p := q end;
+      while r <> nil do with r^ do
+        begin
+	  for j := 1 to cnt do write(em, bytes[j]);
+	  r := next
+        end
+    end
+end;
+
+function setmark:integer;
+var p:mp; nm:boolean;
+begin nm := false;
+  if mhead <> nil then with mhead^ do
+    if (where = bcnt) and (ohead^.cnt = 0) then
+      begin count := count + 1; nm := true end;
+  if not nm then
+    begin new(p); newoutrec;
+      with p^ do
+        begin where := bcnt; count := 1; next := mhead end;
+      mhead := p;
+    end;
+  setmark := bcnt
+end;
+
+procedure freemark(m : integer);
+var p, q : mp;
+begin assert(mhead <> nil); p := mhead; q := p;
+  while p^.where <> m do
+    begin q := p; p := p^.next; assert(p <> nil) end;
+  with p^ do
+    begin assert(count > 0); count := count - 1; if count = 0 then
+      begin
+	if p = mhead then begin mhead := next; reloutrec end
+	else q^.next := next
+      end
+end end;
+
+procedure exchange(n,m:integer);
+var i:integer;
+    p,q,r:op;
+begin assert(m >= n);
+  if n <> m then
+    begin
+      p := ohead;
+      for i := bcnt downto m+1 do p := p^.next;
+      q := p;
+      for i := m downto n+1 do q := q^.next;
+      r := ohead; ohead := p^.next; p^.next := q^.next; q^.next := r
+    end
+end;
+#else not NO_EXC
+procedure exchange(l1,l2:integer);
+var d1,d2:integer;
+begin d1:=l2-l1; d2:=lino-l2;
+  if (d1<>0) and (d2<>0) then
+    begin gencst(ps_exc,d1); argcst(d2) end
+end;
+#endif NO_EXC
+
+procedure newilb(i:integer);
+begin lino:=lino+1;
+  if i<sp_nilb0 then put1(i+sp_filb0) else argilb(i)
+end;
+
+function newdlb:integer;
+begin lino:=lino+1; dlbno:=dlbno+1;
+#ifdef  CHL
+  if (opt['g']=off) and (not holdone) then begin genop(ps_exa); argdlb(dlbno) end;
+  if main or holdone then argdlb(dlbno);
+#else
+  argdlb(dlbno);
+#endif
+  newdlb:=dlbno;
+end;
+
+function romstr(typ:byte; siz:integer):integer;
+var i:integer;
+begin romstr:=newdlb;
+#ifdef  CHL
+  if main or holdone then
+#endif
+    begin genop(ps_rom);
+      put1(typ); if typ<>sp_scon then argcst(siz); argcst(ix);
+      for i:=1 to ix do put1(ord(strbuf[i])); argend
+    end;
+end;
+
+{===================================================================}
+
+procedure error(err:integer);
+{as you will notice, all error numbers are preceded by '+' and '0' to
+  ease their renumbering in case of new errornumbers.
+}
+begin
+#ifdef CHL
+	if ((opt['w']=on) and (err<0)) or (err>0) then
+#endif
+	begin 
+		writeln(errors,err,srclino,srcchno);
+  		if err>0 then begin gencst(ps_mes,ms_err); argend end
+	end
+end;
+
+procedure errid(err:integer; var id:idarr);
+begin
+#ifdef CHL
+	if ((opt['w']=on) and (err<0)) or (err>0) then
+#endif
+		begin write(errors,'''',id); error(err) end;
+end;
+
+procedure errint(err:integer; i:integer);
+begin write(errors,i:1); error(err) end;
+
+procedure errasp(err:integer);
+begin if a.asp<>nil then begin error(err); a.asp:=nil end end;
+
+procedure teststandard;
+begin if sopt<>off then error(-(+01)) end;
+
+procedure enterid(fip: ip);
+{enter id pointed at by fip into the name-table,
+  which on each declaration level is organised as
+  an unbalanced binary tree}
+var nam:idarr; lip,lip1:ip; lleft,again:boolean;
+begin nam:=fip^.name; again:=false; assert nam[1]<>' ';
+  lip:=top^.fname;
+  if lip=nil then top^.fname:=fip else
+    begin
+      repeat lip1:=lip;
+	if lip^.name>nam then
+	  begin lip:=lip^.llink; lleft:=true end
+	else
+	  begin if lip^.name=nam then again:=true;  {name conflict}
+	    lip:=lip^.rlink; lleft:=false;
+	  end;
+      until lip=nil;
+      if lleft then lip1^.llink:=fip else lip1^.rlink:=fip
+    end;
+  fip^.llink:=nil; fip^.rlink:=nil;
+  if again then errid(+02,nam);
+end;
+
+{===================================================================}
+
+procedure trace(tname:idarr; fip:ip; var namdlb:integer);
+var i:integer;
+begin
+  if opt['t']<>off then
+    begin
+      if namdlb=0 then
+	begin namdlb:=newdlb; genop(ps_rom); put1(sp_scon); argcst(8);
+	  for i:=1 to 8 do put1(ord(fip^.name[i])); argend;
+	end;
+      laedlb(namdlb); genop(op_cal); argident(tname);
+      gencst(op_asp,sz_addr);
+    end;
+end;
+
+procedure expandnullset(fsp:sp);
+var s:integer;
+begin s:=sizeof(fsp,wordmult)-sz_word;
+  if s<>0 then gencst(op_zer,s); a.asp:=fsp
+end;
+
+procedure push(local:boolean; ad:integer; sz:integer);
+begin assert sz mod sz_word = 0;
+  if sz=sz_word then
+    if local then gencst(op_lol,ad) else genglb(op_loe,ad)
+  else if sz=2*sz_word then
+    if local then gencst(op_ldl,ad) else genglb(op_lde,ad)
+  else
+    begin if local then gencst(op_lal,ad) else genglb(op_lae,ad);
+      gencst(op_loi,sz)
+    end
+end;
+
+procedure pop(local:boolean; ad:integer; sz:integer);
+begin assert sz mod sz_word = 0;
+  if sz=sz_word then
+    if local then gencst(op_stl,ad) else genglb(op_ste,ad)
+  else if sz=2*sz_word then
+    if local then gencst(op_sdl,ad) else genglb(op_sde,ad)
+  else
+    begin if local then gencst(op_lal,ad) else genglb(op_lae,ad);
+      gencst(op_sti,sz)
+    end
+end;
+
+procedure lexaddr(lv:integer; ad:integer);
+begin assert level>=lv;
+  if ad>=0 then gencst(op_lxa,level-lv) else gencst(op_lxl,level-lv);
+  gencst(op_adp,ad)
+end;
+
+procedure loadpos(var p:position; sz:integer);
+begin with p do
+  if lv<=0 then push(global,ad,sz) else
+  if lv=level then push(local,ad,sz) else
+    begin lexaddr(lv,ad); gencst(op_loi,sz) end;
+end;
+
+procedure descraddr(var p:position);
+begin if p.lv=0 then laedlb(p.ad) else loadpos(p,sz_addr) end;
+
+procedure loadaddr;
+begin with a,pos do begin
+  case ak of
+    fixed:
+      if lv<=0 then genglb(op_lae,ad) else
+      if lv=level then gencst(op_lal,ad) else lexaddr(lv,ad);
+    pfixed:
+      loadpos(pos,sz_addr);
+    ploaded:
+      ;
+    indexed:
+      gencst(op_aar,sz_word);
+  end;  {case}
+  ak:=ploaded;
+end end;
+
+procedure load;
+var sz:integer;
+begin with a do begin sz:=sizeof(asp,packbit);
+  if asp<>nil then begin
+    case ak of
+      cst:
+	gencst(op_loc,pos.ad);  {only one-word scalars}
+      fixed:
+	loadpos(pos,sz);
+      pfixed:
+	begin loadpos(pos,sz_addr); gencst(op_loi,sz) end;
+      loaded:
+	;
+      ploaded:
+	gencst(op_loi,sz);
+      indexed:
+	gencst(op_lar,sz_word);
+    end;  {case}
+  if asp^.form = subrange then
+     if sz < sz_word then
+	if asp^.min < 0 then
+	   { do sign extension }
+	   begin gencst(op_loc, sz); gencst(op_loc, sz_word); genop(op_cii) end;
+  end;
+  ak:=loaded;
+end end;
+
+procedure store;
+var sz:integer;
+begin with a,pos do begin sz:=sizeof(asp,packbit);
+  if asp<>nil then
+    case ak of
+      fixed:
+	if lv<=0 then pop(global,ad,sz) else
+	if level=lv then pop(local,ad,sz) else
+	  begin lexaddr(lv,ad); gencst(op_sti,sz) end;
+      pfixed:
+	begin loadpos(pos,sz_addr); gencst(op_sti,sz) end;
+      ploaded:
+	gencst(op_sti,sz);
+      indexed:
+	gencst(op_sar,sz_word);
+    end;  {case}
+end end;
+
+procedure fieldaddr(off:integer);
+begin with a do
+  if (ak=fixed) and not packbit then pos.ad:=pos.ad+off else
+    begin loadaddr; gencst(op_adp,off) end
+end;
+
+procedure loadcheap;
+begin if formof(a.asp,[arrays..records]) then loadaddr else load end;
+
+{===================================================================}
+
+procedure nextch;
+begin
+  eol:=eoln(input); read(input,ch); chsy:=cs[ch];
+  if chsy <> tabch then srcchno:=srcchno+1
+end;
+
+procedure nextln;
+begin
+  if eof(input) then
+    begin
+      if not eofexpected then error(+03) else
+	if fltused then begin gencst(ps_mes,ms_flt); argend end;
+#ifdef STANDARD
+      goto 9999
+#else
+      halt
+#endif
+    end;
+  srcchno:=0; srclino:=srclino+1;
+  if not including then
+    begin srcorig:=srcorig+1; giveline:=true end;
+end;
+
+procedure options(normal:boolean);
+var ci:char; i:integer;
+
+procedure getc;
+begin if normal then nextch else read(errors,ch) end;
+
+begin
+  repeat getc;
+#ifdef CHL
+    if cs[ch]=upper then
+      ch:= chr( ord(ch) + (ord('a')-ord('A')) );  (* shift to lower case *)
+#endif
+    if (ch>='a') and (ch<='z') then
+      begin ci:=ch; getc; i:=0;
+	if ch='+' then begin i:=1; getc end else
+	if ch='-' then getc else
+	if cs[ch]=digit then
+	  repeat i:=i*10 + ord(ch) - ord('0'); getc;
+	  until cs[ch]<>digit
+	else i:=-1;
+	if i>=0 then
+	  if not normal then
+	    begin forceopt[ci]:=true; opt[ci]:=i end
+	  else
+	    if not forceopt[ci] then opt[ci]:=i;
+      end;
+  until ch<>',';
+end;
+
+procedure linedirective;
+var i:integer; fname:fnarr;
+begin
+  repeat nextch until (ch='"') or eol;
+  if eol then error(+04) else
+    begin nextch; i:=0;
+      while (ch<>'"') and not eol do
+	begin
+	  if ch='/' then i:=0 else
+	    begin i:=i+1; if i<=fnmax then fname[i]:=ch end;
+	  nextch
+	end;
+      while i<fnmax do begin i:=i+1; fname[i]:=' ' end;
+      including:=fname<>source; while not eol do nextch
+    end;
+end;
+
+procedure putdig;
+begin ix:=ix+1; if ix<=smax then strbuf[ix]:=ch; nextch end;
+
+procedure inident;
+label 1;
+var i,k:integer;
+begin k:=0; id:=spaces;
+  repeat
+    if chsy=upper then ch:=chr(ord(ch)-ord('A')+ord('a'));
+    if k<idmax then begin k:=k+1; id[k]:=ch end;
+    nextch
+  until chsy>digit;
+	{lower=0,upper=1,digit=2. ugly but fast}
+  for i:=frw[k-1] to frw[k] - 1 do
+    if rw[i]=id then
+      begin sy:=rsy[i]; goto 1 end;
+  sy:=ident;
+1:
+end;
+
+procedure innumber;
+label   1;
+var     i,j:integer;
+	is:packed array[1..imax] of char;
+begin ix:=0; sy:=intcst; val:=0;
+  repeat putdig until chsy<>digit;
+  if (ch='.') or (ch='e') or (ch='E') then
+    begin
+      if ch='.' then
+	begin putdig;
+	  if ch='.' then
+	    begin seconddot:=true; ix:=ix-1; goto 1 end;
+	  if chsy<>digit then error(+05) else
+	    repeat putdig until chsy<>digit;
+	end;
+      if (ch='e') or (ch='E') then
+	begin putdig;
+	  if (ch='+') or (ch='-') then putdig;
+	  if chsy<>digit then error(+06) else
+	    repeat putdig until chsy<>digit;
+	end;
+      if ix>smax then begin error(+07); ix:=smax end;
+      sy:=realcst; fltused:=true; val:=romstr(sp_fcon,sz_real);
+    end;
+1:if (chsy=lower) or (chsy=upper) then teststandard;
+  if sy=intcst then
+    if ix>imax then error(+08) else
+      begin is:='0000000000'; i:=ix; j:=imax;
+	repeat is[j]:=strbuf[i]; j:=j-1; i:=i-1 until i=0;
+	if (is<=maxintstring) and (is<=maxcompintstring) then
+	  repeat j:=j+1; val:=val*10 - ord('0') + ord(is[j]) until j=imax
+	else if (is<=maxlongstring) and (dopt<>off) then
+	  begin sy:=longcst; val:=romstr(sp_icon,sz_long) end
+	else error(+09)
+      end
+end;
+
+procedure instring(qc:char);
+begin ix:=0; zerostring:=qc='"';
+  repeat
+    repeat nextch; ix:=ix+1; if ix<=smax then strbuf[ix]:=ch;
+    until (ch=qc) or eol;
+    if ch=qc then nextch else error(+010);
+  until ch<>qc;
+  if not zerostring then
+    begin ix:=ix-1; if ix=0 then error(+011) end
+  else
+    begin strbuf[ix]:=chr(0); if copt=off then error(+012) end;
+  if (ix=1) and not zerostring then
+    begin sy:=charcst; val:=ord(strbuf[1]) end
+  else
+    begin if ix>smax then begin error(+013); ix:=smax end;
+      sy:=stringcst; val:=romstr(sp_scon,0);
+    end
+end;
+
+procedure incomment;
+var stopc:char;
+begin nextch; stopc:='}';
+  if ch='$' then options(true);
+  while (ch<>'}') and (ch<>stopc) do
+    begin stopc:='}'; if ch='*' then stopc:=')';
+      if eol then nextln; nextch
+    end;
+  if ch<>'}' then teststandard;
+  nextch
+end;
+
+procedure insym;
+  {read next basic symbol of source program and return its
+  description in the global variables sy, op, id, val and ix}
+label 1;
+begin
+1:case chsy of
+    tabch:
+      begin srcchno:=srcchno - srcchno mod 8 + 8; nextch; goto 1 end;
+    layout:
+      begin if eol then nextln; nextch; goto 1 end;
+    lower,upper: inident;
+    digit: innumber;
+    quotech,dquotech:
+      instring(ch);
+    colonch:
+      begin nextch;
+	if ch='=' then begin sy:=becomes; nextch end else sy:=colon1
+      end;
+    periodch:
+      begin nextch;
+	if seconddot then begin seconddot:=false; sy:=colon2 end else
+	if ch='.' then begin sy:=colon2; nextch end else sy:=period
+      end;
+    lessch:
+      begin nextch;
+	if ch='=' then begin sy:=lesy; nextch end else
+	if ch='>' then begin sy:=nesy; nextch end else sy:=ltsy
+      end;
+    greaterch:
+      begin nextch;
+	if ch='=' then begin sy:=gesy; nextch end else sy:=gtsy
+      end;
+    lparentch:
+      begin nextch;
+	if ch<>'*' then sy:=lparent else
+	  begin teststandard; incomment; goto 1 end;
+      end;
+    lbracech:
+      begin incomment; goto 1 end;
+    rparentch,lbrackch,rbrackch,commach,semich,arrowch,
+    plusch,minch,slash,star,equal:
+      begin sy:=csy[chsy]; nextch end;
+    others:
+      begin
+	if (ch='#') and (srcchno=1) then linedirective else
+	  begin error(+014); nextch end;
+	goto 1
+      end;
+  end {case}
+end;
+
+procedure nextif(fsy:symbol; err:integer);
+begin if sy=fsy then insym else error(-err) end;
+
+function find1(sys1,sys2:sos; err:integer):boolean;
+{symbol of sys1 expected. return true if sy in sys1}
+begin
+  if not (sy in sys1) then
+    begin error(err); while not (sy in sys1+sys2) do insym end;
+  find1:=sy in sys1
+end;
+
+function find2(sys1,sys2:sos; err:integer):boolean;
+{symbol of sys1+sys2 expected. return true if sy in sys1}
+begin
+  if not (sy in sys1+sys2) then
+    begin error(err); repeat insym until sy in sys1+sys2 end;
+  find2:=sy in sys1
+end;
+
+function find3(sy1:symbol; sys2:sos; err:integer):boolean;
+{symbol sy1 or one of sys2 expected. return true if sy1 found and skip it}
+begin find3:=true;
+  if not (sy in [sy1]+sys2) then
+    begin error(err); repeat insym until sy in [sy1]+sys2 end;
+  if sy=sy1 then insym else find3:=false
+end;
+
+function endofloop(sys1,sys2:sos; sy3:symbol; err:integer):boolean;
+begin endofloop:=false;
+  if find2(sys2+[sy3],sys1,err) then nextif(sy3,err+1)
+  else endofloop:=true;
+end;
+
+function lastsemicolon(sys1,sys2:sos; err:integer):boolean;
+begin lastsemicolon:=true;
+  if not endofloop(sys1,sys2,semicolon,err) then
+    if find2(sys2,sys1,err+2) then lastsemicolon:=false
+end;
+
+{===================================================================}
+
+function searchid(fidcls: setofids):ip;
+{search for current identifier symbol in the name table}
+label 1;
+var lip:ip; ic:idclass;
+begin lastnp:=top;
+  while lastnp<>nil do
+    begin lip:=lastnp^.fname;
+      while lip<>nil do
+	if lip^.name=id then
+	  if lip^.klass in fidcls then
+	    begin
+	      if lip^.klass=vars then if lip^.vpos.lv<>level then
+		lip^.iflag:=lip^.iflag+[noreg];
+	      goto 1
+	    end
+	  else lip:=lip^.rlink
+	else
+	  if lip^.name< id then lip:=lip^.rlink else lip:=lip^.llink;
+      lastnp:=lastnp^.nlink;
+    end;
+  errid(+015,id);
+  if types in fidcls then ic:=types else
+  if vars  in fidcls then ic:=vars  else
+  if konst in fidcls then ic:=konst else
+  if proc  in fidcls then ic:=proc  else
+  if func  in fidcls then ic:=func  else ic:=field;
+  lip:=undefip[ic];
+1:
+  searchid:=lip
+end;
+
+function searchsection(fip: ip):ip;
+{to find record fields and forward declared procedure identifiers
+  -->procedure pfdeclaration
+  -->procedure selector}
+label 1;
+begin
+  while fip<>nil do
+    if fip^.name=id then goto 1 else
+      if fip^.name< id then fip:=fip^.rlink else fip:=fip^.llink;
+1:  searchsection:=fip
+end;
+
+function searchlab(flp:lp; val:integer):lp;
+label 1;
+begin
+  while flp<>nil do
+    if flp^.labval=val then goto 1 else flp:=flp^.nextlp;
+1:searchlab:=flp
+end;
+
+procedure opconvert(ts:twostruct);
+var op:integer;
+begin with a do begin genasp(op_loc);
+  case ts of
+    ir, lr: begin asp:=realptr; op:=op_cif; fltused:=true end;
+    ri:     begin asp:=intptr ; op:=op_cfi; fltused:=true end;
+    rl:     begin asp:=longptr; op:=op_cfi; fltused:=true end;
+    li:     begin asp:=intptr ; op:=op_cii end;
+    il:     begin asp:=longptr; op:=op_cii end;
+  end;
+  genasp(op_loc); genop(op)
+end end;
+
+procedure negate;
+begin if a.asp=realptr then genasp(op_ngf) else genasp(op_ngi) end;
+
+function desub(fsp:sp):sp;
+begin if formof(fsp,[subrange]) then fsp:=fsp^.rangetype; desub:=fsp end;
+
+function nicescalar(fsp:sp):boolean;
+begin
+  if fsp=nil then nicescalar:=true else
+    nicescalar:=(fsp^.form=scalar) and (fsp<>realptr) and (fsp<>longptr)
+end;
+
+function bounded(fsp:sp):boolean;
+begin bounded:=false;
+  if fsp<>nil then
+    if fsp^.form=subrange then bounded:=true else
+    if fsp^.form=scalar then bounded:=fsp^.fconst<>nil
+end;
+
+procedure bounds(fsp:sp; var fmin,fmax:integer);
+begin
+  if fsp=nil then
+    begin fmin:=0; fmax:=0 end
+  else
+    case fsp^.form of
+    subrange:
+      begin fmin:=fsp^.min; fmax:=fsp^.max end;
+    scalar:
+      begin fmin:=0; fmax:=fsp^.fconst^.value end
+    end
+end;
+
+procedure genrck(fsp:sp);
+var min,max,sno:integer;
+begin
+  if opt['r']<>off then if bounded(fsp) then
+    begin
+      if fsp^.form=scalar then sno:=fsp^.scalno else sno:=fsp^.subrno;
+      if sno=0 then
+	begin bounds(fsp,min,max); sno:=newdlb;
+	  gencst(ps_rom,min); argcst(max); argend;
+	  if fsp^.form=scalar then fsp^.scalno:=sno else fsp^.subrno:=sno
+	end;
+      laedlb(sno); gencst(op_rck,sz_word);
+    end
+end;
+
+procedure checkbnds(fsp:sp);
+var min1,max1,min2,max2:integer;
+begin
+  if bounded(fsp) then
+    if not bounded(a.asp) then genrck(fsp) else
+      begin bounds(fsp,min1,max1); bounds(a.asp,min2,max2);
+	if (min2<min1) or (max2>max1) then
+	  genrck(fsp);
+      end;
+  a.asp:=fsp;
+end;
+
+function eqstruct(p,q:sp):boolean;
+begin eqstruct:=(p=q) or (p=nil) or (q=nil) end;
+
+function string(fsp:sp):boolean;
+var lsp:sp;
+begin string:=false;
+  if formof(fsp,[arrays]) then
+    if eqstruct(fsp^.aeltype,charptr) then
+      if spack in fsp^.sflag then
+	begin lsp:=fsp^.inxtype;
+	  if lsp=nil then string:=true else
+	    if lsp^.form=subrange then
+	      if lsp^.rangetype=intptr then
+		if lsp^.min=1 then
+		  string:=true
+	end
+end;
+
+function compat(p,q:sp):twostruct;
+begin compat:=noteq;
+  if eqstruct(p,q) then compat:=eq else
+    begin p:=desub(p); q:=desub(q);
+      if eqstruct(p,q) then compat:=subeq else
+      if p^.form=q^.form then
+	case p^.form of
+	  scalar:
+	    if (p=intptr) and (q=realptr) then compat:=ir else
+	    if (p=realptr) and (q=intptr) then compat:=ri else
+	    if (p=intptr) and (q=longptr) then compat:=il else
+	    if (p=longptr) and (q=intptr) then compat:=li else
+	    if (p=longptr) and (q=realptr) then compat:=lr else
+	    if (p=realptr) and (q=longptr) then compat:=rl else
+		;
+	  pointer:
+	    if (p=nilptr) or (q=nilptr) then compat:=eq;
+	  power:
+	    if p=nullset then compat:=es else
+	    if q=nullset then compat:=se else
+	    if compat(p^.elset,q^.elset) <= subeq then
+	      if p^.sflag=q^.sflag then compat:=eq;
+	  arrays:
+	    if string(p) and string(q) and (p^.size=q^.size) then compat:=eq;
+	  files,carray,records: ;
+	end;
+    end
+end;
+
+procedure checkasp(fsp:sp; err:integer);
+var ts:twostruct;
+begin
+  ts:=compat(a.asp,fsp);
+  case ts of
+    eq:
+      if fsp<>nil then if withfile in fsp^.sflag then errasp(err);
+    subeq:
+      checkbnds(fsp);
+    li:
+      begin opconvert(ts); checkasp(fsp,err) end;
+    il,rl,lr,ir:
+      opconvert(ts);
+    es:
+      expandnullset(fsp);
+    noteq,ri,se:
+      errasp(err);
+  end
+end;
+
+procedure force(fsp:sp; err:integer);
+begin load; checkasp(fsp,err) end;
+
+function newident(kl:idclass; idt:sp; nxt:ip; err:integer):ip;
+begin newident:=nil;
+  if sy<>ident then error(err) else
+    begin newident:=newip(kl,id,idt,nxt); insym end
+end;
+
+function stringstruct:sp;
+var lsp:sp;
+begin {only used when ix and zerostring are still valid}
+  if zerostring then lsp:=zeroptr else
+    begin lsp:=newsp(arrays,ix*sz_char); lsp^.sflag:=[spack];
+      lsp^.aeltype:=charptr; lsp^.inxtype:=nil;
+    end;
+  stringstruct:=lsp;
+end;
+
+function posaddr(var lb:integer; fsp:sp; partword:boolean):integer;
+var sz:integer;
+begin sz:=sizeof(fsp,partword);
+  if sz_int = 2 then
+    if lb >= MI2-sz-sz_word then begin error(+016); lb:=0 end;
+  if not partword or (sz>=sz_word) then
+    while lb mod sz_word <> 0 do lb:=lb+1;
+  posaddr:=lb;
+  lb:=lb+sz
+end;
+
+function negaddr(fsp:sp):integer;
+var sz:integer;
+begin with b do begin
+  sz:=sizeof(fsp,wordmult);
+  if sz_int = 2 then
+    if reglb <= -MI2+sz+sz_word then begin error(+017); reglb:=0 end;
+  reglb:=reglb-sz;
+  while reglb mod sz_word <> 0 do reglb:=reglb-1;
+  if reglb < minlb then minlb:=reglb;
+  negaddr:=reglb
+end end;
+
+procedure temporary(fsp:sp;r:integer);
+begin inita(fsp,negaddr(fsp));
+  if r>=0 then genreg(sizeof(fsp,wordmult),a.pos.ad,r)
+end;
+
+procedure genhol;
+var sz: integer;
+begin
+#ifdef  CHL
+  holdone := true;
+  if opt['g']=off then begin
+    genop(ps_exa); argdlb(glbdata);
+    if main then begin 
+      sz:=posaddr(holeb,nil,false);
+      argdlb(glbdata);
+      gencst(ps_bss,sz);
+      if sz_word = 4 then begin put1(sp_cst4); put1(0); put1(0); end
+      else put1(sp_cst2);
+      put1(0); put1(128);	 	{ 1000000000000000 pattern}
+      argcst(0);
+    end
+  end
+  else
+  begin
+    if main then sz:=posaddr(holeb,nil,false);
+#else
+  sz:=posaddr(holeb,nil,false);
+  begin
+#endif
+    gencst(ps_hol,sz);
+    if sz_word = 4 then begin put1(sp_cst4); put1(0); put1(0); end
+    else put1(sp_cst2);
+    put1(0); put1(128);	 	{ 1000000000000000 pattern}
+    argcst(0);
+  end;
+  level:=1
+end;
+
+function arraysize(fsp:sp; pack:boolean):integer;
+var sz,min,max,tot,n:integer;
+begin sz:=sizeof(fsp^.aeltype,pack);
+  bounds(fsp^.inxtype,min,max);
+  fsp^.arpos.lv:=0; fsp^.arpos.ad:=newdlb;
+#ifdef  CHL
+  if main or holdone then
+#endif
+    begin
+      gencst(ps_rom,min);
+#ifdef	CHL
+      if opt['r']<>on then 
+	   if min<0 then argcst(maxint)
+	   else argcst(maxint-min)
+      else
+           argcst(max-min); 
+#else
+      argcst(max-min);
+#endif
+      argcst(sz); argend
+    end;
+  n:=max-min+1; tot:=sz*n;
+  if sz<>0 then if tot div sz <> n then begin error(+018); tot:=0 end;
+  arraysize:=tot
+end;
+
+procedure treewalk(fip:ip);
+var lsp:sp; i,sz:integer;
+begin
+  if fip<>nil then
+    begin treewalk(fip^.llink); treewalk(fip^.rlink);
+      if fip^.klass=vars then
+	begin if not (used in fip^.iflag) then errid(-(+019),fip^.name);
+	  if not (assigned in fip^.iflag) then errid(-(+020),fip^.name);
+	  lsp:=fip^.idtype;
+	  if level<>1 then 
+	   if (refer in fip^.iflag) or not (noreg in fip^.iflag) then
+	    if (refer in fip^.iflag) or formof(lsp,[pointer]) then
+	      genreg(sz_addr,fip^.vpos.ad,reg_pointer)
+	    else
+	      begin sz:=sizeof(lsp,wordmult);
+		if loopvar in fip^.iflag then
+		  genreg(sz,fip^.vpos.ad,reg_loop)
+		else if lsp=realptr then
+		  genreg(sz,fip^.vpos.ad,reg_float)
+		else
+		  genreg(sz,fip^.vpos.ad,reg_any);
+	      end;
+	  if lsp<>nil then if withfile in lsp^.sflag then
+	    if lsp^.form=files then
+	      if level=1 then
+		begin
+		  for i:=2 to argc do with argv[i] do
+		    if name=fip^.name then ad:=fip^.vpos.ad
+		end
+	      else
+		begin
+		  if not (refer in fip^.iflag) then
+		    begin gencst(op_lal,fip^.vpos.ad); gensp(CLS,sz_addr)
+		    end
+		end
+	    else
+	      if level<>1 then errid(-(+021),fip^.name)
+	end
+    end
+end;
+
+procedure constant(fsys:sos; var fsp:sp; var fval:integer);
+var signed,min:boolean; lip:ip;
+begin signed:=(sy=plussy) or (sy=minsy);
+  if signed then begin min:=sy=minsy; insym end else min:=false;
+  if find1([ident..stringcst],fsys,+022) then
+    begin fval:=val;
+      case sy of
+	stringcst: fsp:=stringstruct;
+	charcst: fsp:=charptr;
+	intcst: fsp:=intptr;
+	realcst: fsp:=realptr;
+	longcst: fsp:=longptr;
+	ident:
+	  begin lip:=searchid([konst]);
+	    fsp:=lip^.idtype; fval:=lip^.value;
+	  end
+      end;  {case}
+      if signed then
+	if (fsp<>intptr) and (fsp<>realptr) and (fsp<>longptr) then
+	  error(+023)
+	else if min then fval:= -fval;
+		{note: negating the v-number for reals and longs}
+      insym;
+    end
+  else begin fsp:=nil; fval:=0 end;
+end;
+
+function cstinteger(fsys:sos; fsp:sp; err:integer):integer;
+var lsp:sp; lval,min,max:integer;
+begin constant(fsys,lsp,lval);
+  if fsp<>lsp then
+    if not eqstruct(desub(fsp),lsp) then
+      begin error(err); lval:=0 end
+    else if bounded(fsp) then
+      begin bounds(fsp,min,max);
+	if (lval<min) or (lval>max) then error(+024)
+      end;
+  cstinteger:=lval
+end;
+
+{===================================================================}
+
+function typid(err:integer):sp;
+var lip:ip; lsp:sp;
+begin lsp:=nil;
+  if sy<>ident then error(err) else
+    begin lip:=searchid([types]); lsp:=lip^.idtype; insym end;
+  typid:=lsp
+end;
+
+function simpletyp(fsys:sos):sp;
+var lsp,lsp1:sp; lip,hip:ip; min,max:integer; lnp:np;
+    newsubrange:boolean;
+begin lsp:=nil;
+  if find1([ident..lparent],fsys,+025) then
+    if sy=lparent then
+      begin insym; lnp:=top;   {decl. consts local to innermost block}
+	while top^.occur<>blck do top:=top^.nlink;
+	lsp:=newsp(scalar,sz_word); hip:=nil; max:=0;
+	repeat lip:=newident(konst,lsp,hip,+026);
+	  if lip<>nil then
+	    begin enterid(lip); hip:=lip; lip^.value:=max; max:=max+1 end;
+	until endofloop(fsys+[rparent],[ident],comma,+027);  {+028}
+	if max<=MU1 then lsp^.size:=sz_byte
+#if EM_WSIZE == 4
+	else if max <= MU2 then lsp^.size := 2*sz_byte
+#endif
+	;
+	lsp^.fconst:=hip; top:=lnp; nextif(rparent,+029);
+      end
+    else
+      begin newsubrange:=true;
+	if sy=ident then
+	  begin lip:=searchid([types,konst]); insym;
+	    if lip^.klass=types then
+	      begin lsp:=lip^.idtype; newsubrange:=false end
+	    else
+	      begin lsp1:=lip^.idtype; min:=lip^.value end
+	  end
+	else constant(fsys+[colon2,ident..plussy],lsp1,min);
+	if newsubrange then
+	  begin lsp:=newsp(subrange,sz_word); lsp^.subrno:=0;
+	    if not nicescalar(lsp1) then
+	      begin error(+030); lsp1:=nil; min:=0 end;
+	    lsp^.rangetype:=lsp1;
+	    nextif(colon2,+031); max:=cstinteger(fsys,lsp1,+032);
+	    if min>max then begin error(+033); max:=min end;
+	    if ((min>=0) and (max<=MU1)) or ((min>=-NI1) and (max<=MI1)) then
+		lsp^.size:=sz_byte
+#if EM_WSIZE == 4
+	    else if ((min>=0) and (max<=MU2)) or ((min>=-MI2-1) and (max<=MI2)) then
+		lsp^.size := 2*sz_byte
+#endif
+		;
+	    lsp^.min:=min; lsp^.max:=max
+	  end
+      end;
+  simpletyp:=lsp
+end;
+
+function arraytyp(fsys:sos;
+		  artyp:structform;
+		  sflag:sflagset;
+		  function element(fsys:sos):sp
+		 ):sp;
+var lsp,lsp1,hsp:sp; ok:boolean; sepsy:symbol; lip:ip;
+    oksys:sos;
+begin insym; nextif(lbrack,+034); hsp:=nil;
+  repeat lsp:=newsp(artyp,0); initpos(lsp^.arpos);
+    lsp^.aeltype:=hsp; hsp:=lsp;  {link reversed}
+    if artyp=carray then
+      begin sepsy:=semicolon; oksys:=[ident];
+	lip:=newident(carrbnd,lsp,nil,+035); if lip<>nil then enterid(lip);
+	nextif(colon2,+036);
+	lip:=newident(carrbnd,lsp,lip,+037); if lip<>nil then enterid(lip);
+	nextif(colon1,+038); lsp1:=typid(+039);
+	ok:=nicescalar(desub(lsp1));
+      end
+    else
+      begin sepsy:=comma; oksys:=[ident..lparent];
+	lsp1:=simpletyp(fsys+[comma,rbrack,ofsy,ident..packedsy]);
+	ok:=bounded(lsp1)
+      end;
+    if not ok then begin error(+040); lsp1:=nil end;
+    lsp^.inxtype:=lsp1
+  until endofloop(fsys+[rbrack,ofsy,ident..packedsy],oksys,
+				sepsy,+041);  {+042}
+  nextif(rbrack,+043); nextif(ofsy,+044);
+  lsp:=element(fsys);
+  if lsp<>nil then sflag:=sflag + lsp^.sflag * [withfile];
+  repeat  {reverse links and compute size}
+    lsp1:=hsp^.aeltype; hsp^.aeltype:=lsp; hsp^.sflag:=sflag;
+    if artyp=arrays then hsp^.size:=arraysize(hsp,spack in sflag);
+    lsp:=hsp; hsp:=lsp1
+  until hsp=nil;  {lsp points to array with highest dimension}
+  arraytyp:=lsp
+end;
+
+function typ(fsys:sos):sp;
+var lsp,lsp1:sp; off,sz,min,errno:integer;
+    sflag:sflagset; lnp:np;
+
+function fldlist(fsys:sos):sp;
+	{level 2: <<  typ}
+var fip,hip,lip:ip; lsp:sp;
+
+function varpart(fsys:sos):sp;
+	{level 3: <<  fldlist <<  typ}
+var tip,lip:ip; lsp,headsp,hsp,vsp,tsp,tsp1,tfsp:sp;
+    minoff,maxoff,int,nvar:integer; lid:idarr;
+begin insym; tip:=nil; lip:=nil;
+  tsp:=newsp(tag,0);
+  if sy<>ident then error(+045) else
+    begin lid:=id; insym;
+      if sy=colon1 then
+	begin tip:=newip(field,lid,nil,nil); enterid(tip); insym;
+	  if sy<>ident then error(+046) else
+	    begin lid:=id; insym end;
+	end;
+      if sy=ofsy then  {otherwise you may destroy id}
+	begin id:=lid; lip:=searchid([types]) end;
+    end;
+  if lip=nil then tfsp:=nil else tfsp:=lip^.idtype;
+  if bounded(tfsp) then
+    begin bounds(tfsp,int,nvar); nvar:=nvar-int+1 end
+  else
+    begin nvar:=0; if tfsp<>nil then begin error(+047); tfsp:=nil end end;
+  tsp^.tfldsp:=tfsp;
+  if tip<>nil then  {explicit tag}
+    begin tip^.idtype:=tfsp;
+      tip^.foffset:=posaddr(off,tfsp,spack in sflag)
+    end;
+  nextif(ofsy,+048); minoff:=off; maxoff:=minoff; headsp:=nil;
+  repeat hsp:=nil;  {for each caselabel list}
+    repeat nvar:=nvar-1;
+      int:=cstinteger(fsys+[ident..plussy,comma,colon1,lparent,
+		    semicolon,casesy,rparent],tfsp,+049);
+      lsp:=headsp;  {each label may occur only once}
+      while lsp<>nil do
+	begin if lsp^.varval=int then error(+050);
+	  lsp:=lsp^.nxtvar
+	end;
+      vsp:=newsp(variant,0); vsp^.varval:=int;
+      vsp^.nxtvar:=headsp; headsp:=vsp;  {chain of case labels}
+      vsp^.subtsp:=hsp; hsp:=vsp;
+	    {use this field to link labels with same variant}
+    until endofloop(fsys+[colon1,lparent,semicolon,casesy,rparent],
+		    [ident..plussy],comma,+051);  {+052}
+    nextif(colon1,+053); nextif(lparent,+054);
+    tsp1:=fldlist(fsys+[rparent,semicolon,ident..plussy]);
+    if off>maxoff then maxoff:=off;
+    while vsp<>nil do
+      begin vsp^.size:=off; hsp:=vsp^.subtsp;
+	vsp^.subtsp:=tsp1; vsp:=hsp
+      end;
+    nextif(rparent,+055);
+    off:=minoff;
+  until lastsemicolon(fsys,[ident..plussy],+056);  {+057 +058}
+  if nvar>0 then error(-(+059));
+  tsp^.fstvar:=headsp; tsp^.size:=minoff; off:=maxoff; varpart:=tsp;
+end;
+
+begin  {fldlist}
+  if find2([ident],fsys+[casesy],+060) then
+    repeat lip:=nil; hip:=nil;
+      repeat fip:=newident(field,nil,nil,+061);
+	if fip<>nil then
+	  begin enterid(fip);
+	    if lip=nil then hip:=fip else lip^.next:=fip; lip:=fip;
+	  end;
+      until endofloop(fsys+[colon1,ident..packedsy,semicolon,casesy],
+			      [ident],comma,+062);  {+063}
+      nextif(colon1,+064);
+      lsp:=typ(fsys+[casesy,semicolon]);
+      if lsp<>nil then if withfile in lsp^.sflag then
+	sflag:=sflag+[withfile];
+      while hip<>nil do
+	begin hip^.idtype:=lsp;
+	  hip^.foffset:=posaddr(off,lsp,spack in sflag);
+	  hip:=hip^.next
+	end;
+    until lastsemicolon(fsys+[casesy],[ident],+065);  {+066 +067}
+  if sy=casesy then fldlist:=varpart(fsys) else fldlist:=nil;
+end;
+
+
+begin  {typ}
+  sflag:=[]; lsp:=nil;
+  if sy=packedsy then begin sflag:=[spack]; insym end;
+  if find1([ident..filesy],fsys,+068) then
+    if sy in [ident..arrow] then
+      begin if spack in sflag then error(+069);
+	if sy=arrow then
+	  begin lsp:=newsp(pointer,sz_addr); insym;
+	    if not intypedec then lsp^.eltype:=typid(+070) else
+	      if sy<>ident then error(+071) else
+		begin fwptr:=newip(types,id,lsp,fwptr); insym end
+	  end
+	else lsp:=simpletyp(fsys);
+      end
+    else
+      case sy of
+{<<<<<<<<<<<<}
+arraysy:
+  lsp:=arraytyp(fsys,arrays,sflag,typ);
+recordsy:
+  begin insym;
+    new(lnp,rec); lnp^.occur:=rec; lnp^.nlink:=top; lnp^.fname:=nil; top:=lnp;
+    off:=0; lsp1:=fldlist(fsys+[endsy]);  {fldlist updates off}
+    lsp:=newsp(records,off); lsp^.tagsp:=lsp1;
+    lsp^.fstfld:=top^.fname; lsp^.sflag:=sflag;
+    top:=top^.nlink; nextif(endsy,+072)
+  end;
+setsy:
+  begin insym; nextif(ofsy,+073);
+    lsp:=simpletyp(fsys); lsp1:=desub(lsp); errno:=0;
+    if bounded(lsp1) then
+      begin bounds(lsp1,min,sz);
+	if sz div NB1>=sz_mset then errno:=+074
+      end
+    else if bounded(lsp) then  {subrange of integer}
+      begin bounds(lsp,min,sz);
+	if (min<0) or (sz>=iopt) then errno:=+075;
+	sz:=iopt-1
+      end
+    else if lsp=intptr then
+      begin sz:=iopt-1; errno:=-(+076) end
+    else
+      errno:=+077;
+    if errno<>0 then
+      begin error(errno); if errno>0 then begin lsp1:=nil; sz:=0 end end;
+    lsp:=newsp(power,sz div NB1 +1); lsp^.elset:=lsp1;
+  end;
+filesy:
+  begin insym; nextif(ofsy,+078); lsp1:=typ(fsys);
+    if lsp1<>nil then if withfile in lsp1^.sflag then error(-(+079));
+    sz:=sizeof(lsp1,wordpart); if sz<sz_buff then sz:=sz_buff;
+    lsp:=newsp(files,sz+sz_head); lsp^.filtype:=lsp1;
+  end;
+{>>>>>>>>>>>>}
+      end;  {case}
+  typ:=lsp;
+end;
+
+function vpartyp(fsys:sos):sp;
+begin
+  if find2([arraysy],fsys+[ident],+080) then
+    vpartyp:=arraytyp(fsys,carray,[],vpartyp)
+  else
+    vpartyp:=typid(+081)
+end;
+
+{===================================================================}
+
+procedure block(fsys:sos; fip:ip); forward;
+	{pfdeclaration calls block. With a more obscure lexical
+	  structure this forward declaration can be avoided}
+
+procedure labeldeclaration(fsys:sos);
+var llp:lp;
+begin with b do begin
+  repeat
+    if sy<>intcst then error(+082) else
+      begin
+	if searchlab(lchain,val)<>nil then errint(+083,val) else
+	  begin new(llp); llp^.labval:=val;
+	    if val>9999 then teststandard;
+	    ilbno:=ilbno+1; llp^.labname:=ilbno; llp^.labdlb:=0;
+	    llp^.seen:=false; llp^.nextlp:=lchain; lchain:=llp;
+	  end;
+	insym
+      end
+  until endofloop(fsys+[semicolon],[intcst],comma,+084);  {+085}
+  nextif(semicolon,+086)
+end end;
+
+procedure constdefinition(fsys:sos);
+var lip:ip;
+begin
+  repeat lip:=newident(konst,nil,nil,+087);
+    if lip<>nil then
+      begin nextif(eqsy,+088);
+	constant(fsys+[semicolon,ident],lip^.idtype,lip^.value);
+	nextif(semicolon,+089); enterid(lip);
+      end;
+  until not find2([ident],fsys,+090);
+end;
+
+procedure typedefinition(fsys:sos);
+var lip:ip;
+begin fwptr:=nil; intypedec:=true;
+  repeat lip:=newident(types,nil,nil,+091);
+    if lip<>nil then
+      begin nextif(eqsy,+092);
+	lip^.idtype:=typ(fsys+[semicolon,ident]);
+	nextif(semicolon,+093); enterid(lip);
+      end;
+  until not find2([ident],fsys,+094);
+  assert sy<>ident;
+  while fwptr<>nil do
+    begin
+      id:=fwptr^.name; lip:=searchid([types]);
+      fwptr^.idtype^.eltype:=lip^.idtype; fwptr:=fwptr^.next
+    end;
+  intypedec:=false;
+end;
+
+procedure vardeclaration(fsys:sos);
+var lip,hip,vip:ip; lsp:sp;
+begin
+  repeat hip:=nil; lip:=nil;
+    repeat vip:=newident(vars,nil,nil,+095);
+      if vip<>nil then
+	begin enterid(vip); vip^.iflag:=[];
+	  if lip=nil then hip:=vip else lip^.next:=vip; lip:=vip;
+	end;
+    until endofloop(fsys+[colon1,ident..packedsy],[ident],comma,+096);  {+097}
+    nextif(colon1,+098);
+    lsp:=typ(fsys+[semicolon,ident]);
+    while hip<>nil do
+      begin hip^.idtype:=lsp;
+	if level<=1 then
+	  hip^.vpos.ad:=posaddr(holeb,lsp,false)
+	else
+	  hip^.vpos.ad:=negaddr(lsp);
+	hip:=hip^.next
+      end;
+    nextif(semicolon,+099);
+  until not find2([ident],fsys,+0100);
+end;
+
+procedure pfhead(fsys:sos;var fip:ip;var again:boolean;param:boolean);
+  forward;
+
+procedure parlist(fsys:sos; slink:boolean; var tip:ip; var maxlb:integer);
+var lastip,hip,lip,pip:ip; lsp,tsp:sp; iflag:iflagset; again:boolean;
+#ifdef  CHL
+  function posaddr(var lb:integer; fsp:sp; partword:boolean):integer;
+  var sz:integer;
+  begin sz:=sizeof(fsp,partword);
+    lb:=lb+sz;
+    posaddr:=sz;
+  end;
+#endif
+begin tip:=nil; lastip:=nil;
+  maxlb:=0; if slink then maxlb:=sz_addr;
+  repeat  {once for each formal-parameter-section}
+    if find1([ident,varsy,procsy,funcsy],fsys+[semicolon],+0101) then
+      begin
+	if (sy=procsy) or (sy=funcsy) then
+	  begin
+	    pfhead(fsys+[semicolon,ident,varsy,procsy,funcsy],hip,again,true);
+	    hip^.pfpos.ad:=posaddr(maxlb,procptr,false);
+	    hip^.pfkind:=formal; lip:=hip;
+	    top:=top^.nlink; level:=level-1
+	  end
+	else
+	  begin hip:=nil; lip:=nil; iflag:=[assigned];
+	    if sy=varsy then
+	      begin iflag:=[refer,assigned,used]; insym end;
+	    repeat pip:=newident(vars,nil,nil,+0102);
+	      if pip<>nil then
+		begin enterid(pip); pip^.iflag:=iflag;
+		  if lip=nil then hip:=pip else lip^.next:=pip; lip:=pip;
+		end;
+	      iflag:=iflag+[samesect];
+	    until endofloop(fsys+[semicolon,colon1],[ident],comma,+0103);
+	    {+0104}
+	    nextif(colon1,+0105);
+	    if refer in iflag then
+	      begin lsp:=vpartyp(fsys+[semicolon]); tsp:=lsp;
+		while formof(tsp,[carray]) do
+		  begin tsp^.arpos.ad:=posaddr(maxlb,nilptr,false);
+		    tsp:=tsp^.aeltype
+		  end;
+		tsp:=nilptr;
+	      end
+	    else
+	      begin lsp:=typid(+0106); tsp:=lsp end;
+	    pip:=hip;
+	    while pip<>nil do
+	      begin pip^.vpos.ad:=posaddr(maxlb,tsp,false); pip^.idtype:=lsp;
+		pip:=pip^.next
+	      end;
+	  end;
+	if lastip=nil then tip:=hip else lastip^.next:=hip; lastip:=lip;
+     end;
+  until endofloop(fsys,[ident,varsy,procsy,funcsy],semicolon,+0107);  {+0108}
+#ifdef  CHL
+  hip:=tip;
+  while hip<>nil do
+    begin
+     if hip^.klass=vars then
+	begin maxlb:=maxlb-hip^.vpos.ad; hip^.vpos.ad:=maxlb end
+      else begin maxlb:=maxlb-hip^.pfpos.ad; hip^.pfpos.ad:=maxlb end;
+      hip:=hip^.next;
+    end;
+#endif
+end;
+
+procedure pfhead;  {forward declared}
+var lip:ip; lsp:sp; lnp:np; kl:idclass;
+begin lip:=nil; again:=false;
+  if sy=procsy then kl:=proc else
+    begin kl:=func; fsys:=fsys+[colon1,ident] end;
+  insym;
+  if sy<>ident then begin error(+0109); id:=spaces end;
+  if not param then lip:=searchsection(top^.fname);
+  if lip<>nil then
+    if (lip^.klass<>kl) or (lip^.pfkind<>forward) then errid(+0110,id) else
+      begin b.forwcount:=b.forwcount-1; again:=true end;
+  if again then insym else
+    begin lip:=newip(kl,id,nil,nil);
+      if sy=ident then begin enterid(lip); insym end;
+      lastpfno:=lastpfno+1; lip^.pfno:=lastpfno;
+    end;
+  level:=level+1;
+  new(lnp,blck); lnp^.occur:=blck; lnp^.nlink:=top; top:=lnp;
+  if again then lnp^.fname:=lip^.parhead else
+    begin lnp^.fname:=nil;
+      if find3(lparent,fsys,+0111) then
+	begin parlist(fsys+[rparent],lip^.pfpos.lv>1,lip^.parhead,lip^.maxlb);
+	  nextif(rparent,+0112)
+	end;
+    end;
+  if (kl=func) and not again then
+    begin nextif(colon1,+0113); lsp:=typid(+0114);
+      if formof(lsp,[power..tag]) then
+	begin error(+0115); lsp:=nil end;
+      lip^.idtype:=lsp;
+    end;
+  fip:=lip;
+end;
+
+procedure pfdeclaration(fsys:sos);
+var lip:ip; again,headonly:boolean; markp:^integer; lbp:bp; kind:kindofpf;
+begin with b do begin
+  pfhead(fsys+[ident,semicolon,labelsy..beginsy],lip,again,false);
+  nextif(semicolon,+0116);
+  if find1([ident,labelsy..beginsy],fsys+[semicolon],+0117) then
+    begin headonly:=sy=ident;
+      if headonly then
+	begin kind:=standard;
+	  if id='forward ' then kind:=forward else
+	  if id='extern  ' then kind:=extern  else
+	  if id='varargs ' then kind:=varargs else errid(+0118,id);
+	  if kind<>standard then
+	    begin insym; lip^.pfkind:=kind;
+	      if kind=forward then
+		if again then errid(+0119,lip^.name) else
+		  forwcount:=forwcount+1
+	      else
+		begin 
+#ifdef CHL
+		if kind<>extern then 
+#endif
+		    lip^.pfpos.lv:=1; 
+		    teststandard 
+	        end
+	    end;
+	end;
+      if not again then
+#ifdef  CHL
+	if (lip^.pfpos.lv<=1) or (opt['e']=on) then
+#else
+	if lip^.pfpos.lv<=1 then
+#endif
+	  genpnam(ps_exp,lip) else genpnam(ps_inp,lip);
+      if not headonly then
+	begin lip^.pfkind:=actual;
+#ifndef STANDARD
+	  mark(markp);
+#endif
+	  new(lbp); lbp^:=b; nextbp:=lbp;
+	  minlb:=0; ilbno:=0; forwcount:=0; lchain:=nil;
+#ifdef  CHL
+	  reglb:=-sz_word;
+	  tip:=lip;
+#else
+	  reglb:=0;
+#endif
+	  block(fsys+[semicolon],lip);
+	  b:=nextbp^;
+#ifndef STANDARD
+	  release(markp);
+#endif
+	end;
+    end;
+  if not main then eofexpected:=forwcount=0;
+  nextif(semicolon,+0120);
+  level:=level-1; top:=top^.nlink;
+end end;
+
+{===================================================================}
+
+procedure expression(fsys:sos); forward;
+	{this forward declaration cannot be avoided}
+
+procedure selectarrayelement(fsys:sos);
+var isp,lsp:sp;
+begin
+  repeat loadaddr; isp:=nil;
+    if formof(a.asp,[arrays,carray]) then isp:=a.asp^.inxtype else
+      errasp(+0121);
+    lsp:=a.asp;
+    expression(fsys+[comma]); force(desub(isp),+0122);
+		{no range check}
+    if lsp<>nil then
+      begin a.packbit:=spack in lsp^.sflag;
+	descraddr(lsp^.arpos); lsp:=lsp^.aeltype
+      end;
+    a.asp:=lsp; a.ak:=indexed;
+  until endofloop(fsys,[notsy..lparent],comma,+0123);  {+0124}
+end;
+
+procedure selector(fsys: sos; fip:ip; iflag:iflagset);
+{selector computes the address of any kind of variable.
+  Four possibilities:
+  1.for direct accessable variables (fixed), a contains offset and level,
+  2.for indirect accessable variables (ploaded), the address is on the stack.
+  3.for array elements, the top of stack gives the index (one word).
+    The address of the array is beneath it.
+  4.for variables with address in direct accessible pointer variable (pfixed),
+    the offset and level of the pointer is stored in a.
+  If a.asp=nil then an error occurred else a.asp gives
+  the type of the variable.
+}
+var lip:ip;
+begin inita(fip^.idtype,0);
+  case fip^.klass of
+    vars: with a do
+      begin pos:=fip^.vpos; if refer in fip^.iflag then ak:=pfixed end;
+    field:
+      begin a:=lastnp^.wa; fieldaddr(fip^.foffset); a.asp:=fip^.idtype end;
+    func: with a do
+      if fip^.pfkind=standard then errasp(+0125) else
+      if (fip^.pfpos.lv>=level-1) and (fip<>currproc) then error(+0126) else
+      if fip^.pfkind<>actual then error(+0127) else
+	begin pos:=fip^.pfpos; pos.lv:=pos.lv+1;
+	  if sy=arrow then error(+0128);
+	end
+  end;  {case}
+  if (sy=lbrack) or (sy=period) then iflag:=iflag+[noreg];
+  while find2([lbrack,period,arrow],fsys,+0129) do with a do
+    if sy=lbrack then
+      begin insym; selectarrayelement(fsys+[rbrack,lbrack,period,arrow]);
+	nextif(rbrack,+0130);
+      end else
+    if sy=period then
+      begin insym;
+	if sy<>ident then error(+0131) else
+	  begin
+	    if not formof(asp,[records]) then errasp(+0132) else
+	      begin lip:=searchsection(asp^.fstfld);
+		if lip=nil then begin errid(+0133,id); asp:=nil end else
+		  begin packbit:=spack in asp^.sflag;
+		    fieldaddr(lip^.foffset); asp:=lip^.idtype
+		  end
+	      end;
+	    insym
+	  end
+      end
+    else
+      begin insym; iflag:=[used];
+	if asp<>nil then
+	  if asp=zeroptr then errasp(+0134) else
+	  if asp^.form=pointer then
+	    begin
+	      if ak=fixed then ak:=pfixed else
+		begin load; ak:=ploaded end;
+	      asp:=asp^.eltype
+	    end else
+	  if asp^.form=files then
+	    begin loadaddr; gensp(WDW,sz_addr); gencst(op_lfr,sz_addr);
+	      asp:=asp^.filtype; ak:=ploaded; packbit:=true;
+	    end
+	  else errasp(+0135);
+      end;
+  fip^.iflag:=fip^.iflag+iflag;
+end;
+
+procedure variable(fsys:sos);
+var lip: ip;
+begin
+  if sy=ident then
+    begin lip:=searchid([vars,field]); insym;
+      selector(fsys,lip,[used,assigned,noreg])
+    end
+  else begin error(+0136); inita(nil,0) end;
+end;
+
+{===================================================================}
+
+function plistequal(p1,p2:ip):boolean;
+var ok:boolean; q1,q2:sp;
+begin plistequal:=eqstruct(p1^.idtype,p2^.idtype);
+  p1:=p1^.parhead; p2:=p2^.parhead;
+  while (p1<>nil) and (p2<>nil) do
+    begin ok:=false;
+      if p1^.klass=p2^.klass then
+	if p1^.klass<>vars then ok:=plistequal(p1,p2) else
+	  begin q1:=p1^.idtype; q2:=p2^.idtype; ok:=true;
+	    while ok and formof(q1,[carray]) and formof(q2,[carray]) do
+	      begin ok:=eqstruct(q1^.inxtype,q2^.inxtype);
+		q1:=q1^.aeltype; q2:=q2^.aeltype;
+	      end;
+	    if not (eqstruct(q1,q2) and
+		    (p1^.iflag*[refer,samesect] = p2^.iflag*[refer,samesect]))
+	      then ok:=false;
+	  end;
+      if not ok then plistequal:=false;
+      p1:=p1^.next; p2:=p2^.next
+    end;
+  if (p1<>nil) or (p2<>nil) then plistequal:=false
+end;
+
+procedure callnonstandard(fsys:sos; moreargs:boolean; fip:ip);
+var nxt,lip:ip; l0,l1,l2,l3,sz:integer; lsp,savasp:sp;
+begin with a do begin
+  l0:=newmark; l1:=newmark; sz:=0; nxt:=fip^.parhead;
+  while moreargs do
+    begin
+      if nxt=nil then
+	begin if fip^.pfkind<>varargs then error(+0137);
+	  expression(fsys); load; sz:=sz+sizeof(asp,wordmult)
+	end
+      else
+	begin lsp:=nxt^.idtype;
+	  if nxt^.klass<>vars then  {proc or func}
+	    begin inita(procptr,0); sz:=sz+sz_proc;
+	      if sy<>ident then error(+0138) else
+		begin lip:=searchid([nxt^.klass]); insym;
+		  if lip^.pfkind=standard then error(+0139) else
+		  if not plistequal(nxt,lip) then error(+0140)
+		  else
+		    begin pos:=lip^.pfpos;
+		      if lip^.pfkind=formal then load else
+			begin
+			  if lip^.pfpos.lv<=1 then gencst(op_zer,sz_addr) else
+			    gencst(op_lxl,level-lip^.pfpos.lv);
+			  genpnam(op_lpi,lip)
+			end
+		    end
+		end
+	    end
+	  else if not (refer in nxt^.iflag) then  {call by value}
+	    begin expression(fsys); force(lsp,+0141);
+	      sz:=sz+sizeof(asp,wordmult);
+	    end
+	  else  {call by reference}
+	    begin variable(fsys); loadaddr; sz:=sz+sz_addr;
+	      if samesect in nxt^.iflag then lsp:=savasp else
+		begin savasp:=asp; l2:=newmark;
+		  while formof(lsp,[carray])
+			and formof(asp,[arrays,carray]) do
+		    if (compat(lsp^.inxtype,asp^.inxtype) > subeq) or
+			  (lsp^.sflag<>asp^.sflag) then errasp(+0142) else
+		      begin l3:=newmark; descraddr(asp^.arpos); exchange(l2,l3);
+			relmark(l3);
+			sz:=sz+sz_addr; asp:=asp^.aeltype; lsp:=lsp^.aeltype
+		      end;
+		  relmark(l2)
+		end;
+	      if not eqstruct(asp,lsp) then errasp(+0143);
+	      if packbit then errasp(+0144);
+	    end;
+	  nxt:=nxt^.next
+	end;
+#ifndef CHL
+      exchange(l0,l1);
+#endif
+      relmark(l1);
+      l1:=newmark; moreargs:=find3(comma,fsys,+0145)
+    end;
+  relmark(l0); relmark(l1);
+  if nxt<>nil then error(+0146);
+  inita(procptr,0); pos:=fip^.pfpos;
+  if fip^.pfkind=formal then
+    with b do
+      begin load; ilbno:=ilbno+2;
+	gencst(op_exg,sz_addr);
+	gencst(op_dup,sz_addr);
+	gencst(op_zer,sz_addr);
+	genop(op_cmp);
+	gencst(op_zeq,ilbno-1);
+	gencst(op_exg,sz_addr);
+	genop(op_cai);
+	gencst(op_asp,sz_addr);
+	gencst(op_bra,ilbno);
+	newilb(ilbno-1);
+	gencst(op_asp,sz_addr);
+	genop(op_cai);
+	newilb(ilbno);
+      end
+  else
+    begin
+      if pos.lv>1 then
+	begin gencst(op_lxl,level-pos.lv); sz:=sz+sz_addr end;
+      genpnam(op_cal,fip)
+    end;
+  if sz<>0 then gencst(op_asp,sz);
+  asp:=fip^.idtype;
+  if asp<>nil then genasp(op_lfr)
+end end;
+
+procedure fileaddr;
+var la:attr;
+begin la:=a; a:=fa; loadaddr; a:=la end;
+
+procedure callr(l1,l2:integer);
+var la:attr; m:libmnem;
+begin with a do begin
+  la:=a; asp:=desub(asp); fileaddr; m:=RDI;
+  if asp<>intptr then
+  if asp=charptr then m:=RDC else
+  if asp=realptr then m:=RDR else
+  if asp=longptr then m:=RDL else errasp(+0147);
+  gensp(m,sz_addr); genasp(op_lfr);
+  if asp<>la.asp then checkbnds(la.asp);
+  a:=la; exchange(l1,l2); store;
+end end;
+
+procedure callw(fsys:sos; l1,l2:integer);
+var m:libmnem; s:integer;
+begin with a do begin
+  fileaddr; exchange(l1,l2); loadcheap; asp:=desub(asp);
+  if string(asp) then
+    begin gencst(op_loc,asp^.size); m:=WRS; s:=sz_addr+sz_word end
+  else
+    begin m:=WRI; s:=sizeof(asp,wordmult);
+      if asp<>intptr then
+      if asp=charptr then m:=WRC else
+      if asp=realptr then m:=WRR else
+      if asp=boolptr then m:=WRB else
+      if asp=zeroptr then m:=WRZ else
+      if asp=longptr then m:=WRL else errasp(+0148);
+    end;
+  if find3(colon1,fsys,+0149) then
+    begin expression(fsys+[colon1]); force(intptr,+0150);
+      m:=succ(m); s:=s+sz_int
+    end;
+  if find3(colon1,fsys,+0151) then
+    begin expression(fsys); force(intptr,+0152); s:=s+sz_int;
+      if m<>WSR then error(+0153) else m:=WRF;
+    end;
+  gensp(m,s+sz_addr);
+end end;
+
+procedure callrw(fsys:sos; lpar,w,ln:boolean);
+var l1,l2,errno:integer; ftype,lsp,fsp:sp; (* savlb:integer;*) m:libmnem;
+begin with b do begin (* savlb:=reglb; *) ftype:=textptr;
+  inita(textptr,argv[ord(w)].ad); a.pos.lv:=0; fa:=a;
+  if lpar then
+    begin l1:=newmark; if w then expression(fsys+[colon1]) else variable(fsys);
+      l2:=newmark;
+      if formof(a.asp,[files]) then
+	begin ftype:=a.asp;
+	  if (a.ak<>fixed) and (a.ak<>pfixed) then
+	    begin loadaddr; temporary(nilptr,reg_pointer);
+	      store; a.ak:=pfixed
+	    end;
+	  fa:=a;  {store does not change a}
+	  if (sy<>comma) and not ln then error(+0154);
+	end
+      else
+	begin if iop[w]=nil then error(+0155);
+	  if w then callw(fsys,l1,l2) else callr(l1,l2)
+	end;
+      relmark(l1); relmark(l2);
+      while find3(comma,fsys,+0156) do with a do
+	begin l1:=newmark;
+	  if w then expression(fsys+[colon1]) else variable(fsys);
+	  l2:=newmark;
+	  if ftype=textptr then
+	    if w then callw(fsys,l1,l2) else callr(l1,l2)
+	  else
+	    begin errno:=+0157; fsp:=ftype^.filtype;
+	      if w then force(fsp,errno) else
+		begin store; lsp:=asp; relmark(l2); l2 := newmark end;
+	      fileaddr; gensp(WDW,sz_addr); gencst(op_lfr,sz_addr);
+	      ak:=ploaded; packbit:=true; asp:=fsp;
+	      if w then store else
+		begin force(lsp,errno); exchange(l1,l2) end;
+	      fileaddr; if w then m:=PUTX else m:=GETX; gensp(m,sz_addr)
+	    end;
+	  relmark(l1); relmark(l2);
+	end;
+    end
+  else
+    if not ln then error(+0158) else
+      if iop[w]=nil then error(+0159);
+  if ln then
+    begin if ftype<>textptr then error(+0160);
+      fileaddr; if w then m:=WLN else m:=RLN; gensp(m,sz_addr)
+    end;
+  (* reglb:=savlb *)
+end end;
+
+procedure callnd(fsys:sos);
+label 1;
+var lsp:sp; int:integer;
+begin with a do begin
+  if asp=zeroptr then errasp(+0161) else asp:=asp^.eltype;
+  while find3(comma,fsys,+0162) do
+    begin
+      if asp<>nil then  {asp of form record or variant}
+	if asp^.form=records then asp:=asp^.tagsp else
+	if asp^.form=variant then asp:=asp^.subtsp else errasp(+0163);
+      if asp=nil then constant(fsys,lsp,int) else
+	begin assert asp^.form=tag;
+	  int:=cstinteger(fsys,asp^.tfldsp,+0164); lsp:=asp^.fstvar;
+	  while lsp<>nil do
+	    if lsp^.varval<>int then lsp:=lsp^.nxtvar else
+	      begin asp:=lsp; goto 1 end;
+	end;
+1:  end;
+  genasp(op_loc)
+end end;
+
+#ifdef  CHL
+function plen:integer;
+{length of parameter space of current proc/func}
+var pip:ip; maxlb,dummy:integer;
+begin
+  if b.tip<>nil then
+    begin
+      maxlb:=ord(b.tip^.pfpos.lv>1)*sz_addr;    {space for static chain}
+      pip:=b.tip^.parhead;
+      while pip<>nil do
+	begin
+	  case pip^.klass of
+	    vars: if refer in pip^.iflag then dummy:=posaddr(maxlb,nilptr,false)
+		  else dummy:=posaddr(maxlb,pip^.idtype,false);
+	    proc,func: dummy:=posaddr(maxlb,procptr,false);
+	  end;
+	  pip:=pip^.next;
+	end;
+      plen:=maxlb;
+    end
+  else error(+0001);
+end {of plen};
+#endif
+
+procedure call(fsys: sos; fip: ip);
+var lkey: standpf; lpar:boolean; lsp,sp1,sp2:sp;
+    m:libmnem; s:integer; b:byte;
+#ifdef  CHL
+    int:integer;
+#endif
+begin with a do begin fsys:=fsys+[comma];
+  lpar:=find3(lparent,fsys,+0165); if lpar then fsys:=fsys+[rparent];
+  if fip^.pfkind<>standard then callnonstandard(fsys,lpar,fip) else
+    begin lkey:=fip^.key; m:=CLS; lsp:=nil;
+      if not lpar then
+	if lkey in [pput..prelease,
+#ifdef  CHL
+		    psetstktop,pmoveleft,
+#endif
+		    fabs..fatn] then error(+0166);
+      if lkey in [pput..ppage,feof,feoln] then
+	begin s:=sz_addr;
+	  if lpar then
+	    begin variable(fsys); loadaddr end
+	  else
+	    begin asp:=textptr;
+	      if iop[lkey=ppage]=nil then errasp(+0167) else
+		genglb(op_lae,argv[ord(lkey=ppage)].ad)
+	    end;
+	  if lkey in [pput..prewrite,ppage,feof,feoln] then
+	    if not formof(asp,[files]) then
+	      begin error(+0168); asp:=textptr end;
+	  if lkey in [pnew,pdispose,
+#ifdef  CHL
+		      penew,pedispose,
+#endif
+		      pmark,prelease] then
+	    if not formof(asp,[pointer]) then
+	      begin error(+0169); asp:=nilptr end;
+	end;
+      case lkey of
+	pread, preadln, pwrite, pwriteln:       {0,1,2,3 resp}
+	  callrw(fsys,lpar,lkey>=pwrite,odd(ord(lkey)));
+	pput: m:=PUTX;
+	pget: m:=GETX;
+	ppage: m:=PAG;
+	preset: m:=OPN;
+	prewrite: m:=CRE;
+#ifdef  CHL
+	penew,
+#endif
+	pnew: m:=NEWX;
+#ifdef  CHL
+	pedispose,
+#endif
+	pdispose: m:=DIS;
+	ppack:
+	  begin sp2:=asp; nextif(comma,+0170); expression(fsys); load;
+	    lsp:=asp; nextif(comma,+0171); variable(fsys); loadaddr;
+	    sp1:=asp; asp:=lsp; m:=PAC
+	  end;
+	punpack:
+	  begin sp1:=asp; nextif(comma,+0172); variable(fsys); loadaddr;
+	    sp2:=asp; nextif(comma,+0173); expression(fsys); load;
+	    m:=UNP
+	  end;
+	pmark: m:=SAV;
+	prelease: m:=RST;
+	phalt:
+	  begin m:=HLT; teststandard;
+	    if lpar then lsp:=intptr else gencst(op_loc,0);
+	  end;
+	feof: m:=EFL;
+	feoln: m:=ELN;
+#ifdef  CHL
+	fasptr: if sz_addr=sz_word then lsp:=intptr else lsp:=longptr;
+	pmoveleft: ;
+	psetstktop, fgetstktop,
+#endif
+	fodd, fchr: lsp:=intptr;
+	fpred: b:=op_dec;
+	fsucc: b:=op_inc;
+	fround: m:=RND;
+	fsin, fcos, fexp, fsqt, flog, fatn: lsp:=realptr;
+#ifdef	CHL
+	fincptr,
+#endif
+	fabs, fsqr, ford, ftrunc: ;
+      end;
+      if lpar then if lkey in [phalt,
+#ifdef  CHL
+			       psetstktop,
+#endif
+			       fabs..fatn] then
+	begin expression(fsys);
+#ifdef  CHL
+	  if lkey in [psetstktop,fgetstktop] then
+	    if ak<>cst then error(+0022)
+	    else
+	      begin
+		if lkey=fgetstktop then gencst(op_lal,plen);
+		checkasp(lsp,+0174);
+		s:=pos.ad + pos.ad mod sz_word;
+		nextif(comma,+0146);
+		expression(fsys);
+		checkasp(lsp,+0174);
+		if s>sz_int then lsp:=longptr;
+		if s>sz_long then lsp:=realptr;
+	      end
+	  else
+	    begin
+#endif
+	     force(lsp,+0174);
+	     s:=sizeof(asp,wordmult)
+#ifdef  CHL
+	    end
+#endif
+	end;
+      if lkey in [ppack,punpack,fabs..fodd] then
+	asp:=desub(asp);
+      case lkey of
+	ppage, feoln:
+	  begin if asp<>textptr then error(+0175); asp:=boolptr end;
+	preset, prewrite:
+	  begin s:=sz_addr+sz_word;
+	    if asp=textptr then gencst(op_loc,0) else
+	      gencst(op_loc,sizeof(asp^.filtype,wordpart));
+	  end;
+	pnew, pdispose:
+	  begin callnd(fsys); s:=sz_addr+sz_word end;
+#ifdef  CHL
+	penew, pedispose:
+	  begin if find1([comma],fsys,+0146) then
+	      begin insym; expression(fsys); force(intptr,+0174) end;
+	    s:=sz_addr+sz_word;
+	  end;
+#endif
+	ppack, punpack:
+	  begin s:=2*sz_addr+sz_int;
+	    if formof(sp1,[arrays,carray])
+	       and formof(sp2,[arrays,carray]) then
+	      if (spack in (sp1^.sflag - sp2^.sflag)) and
+		  eqstruct(sp1^.aeltype,sp2^.aeltype) and
+		  eqstruct(desub(sp1^.inxtype),asp) and
+		  eqstruct(desub(sp2^.inxtype),asp) then
+		begin descraddr(sp1^.arpos); descraddr(sp2^.arpos) end
+	      else error(+0176)
+	    else error(+0177)
+	  end;
+	pmark, prelease: teststandard;
+#ifdef  CHL
+	psetstktop:
+	  if ak=cst then
+	    begin int:=plen+pos.ad;
+	      if find1([comma],fsys,+0146) then
+		begin insym; expression(fsys); force(lsp,+0174) end;
+	      pop(local,int,s);
+	    end
+	  else error(+0001);    {facility not actually needed yet}
+	pmoveleft:
+	  begin
+	    for int:=1 to 3 do
+	      begin
+		expression(fsys);
+		if int<3 then
+		  begin if not formof(asp,[pointer]) then error(+0174);
+		    nextif(comma,+0146) end
+		else force(intptr,+0174);
+		load;
+	      end;
+	    gencst(op_bls,sz_int);
+	  end;
+#endif
+	feof: asp:=boolptr;
+	fabs:
+	  if asp=intptr then m:=ABI else
+	  if asp=longptr then m:=ABL else
+	  if asp=realptr then m:=ABR else errasp(+0178);
+	fsqr:
+	  begin
+	    if (asp=intptr) or (asp=longptr) then b:=op_mli else
+	    if asp=realptr then begin b:=op_mlf; fltused:=true end
+	    else errasp(+0179);
+	    genasp(op_dup); genasp(b)
+	  end;
+	ford:
+#ifdef  CHL
+	    if formof(asp,[pointer]) then
+		if sz_word=sz_addr then asp:=intptr
+		else asp:=longptr
+	    else begin
+		asp:=intptr;
+		if not nicescalar(asp) then errasp(+0180)
+	    end;
+#else
+	    if not nicescalar(asp) then
+	      errasp(+0180); asp:=intptr;
+#endif
+#ifdef  CHL
+	fasptr: asp:=nilptr;
+	fincptr:
+	  begin
+	  if not formof(asp,[pointer]) then errasp(+0174);
+	  nextif(comma,+0146);
+	  load;
+	  expression(fsys);
+	  force(intptr,+0174);
+	  if ak=cst then
+	    gencst(op_adp,pos.ad)
+	  else
+	    begin load; gencst(op_ads,sz_int) end;
+	  asp := nilptr;
+	  ak := loaded;
+	  end;
+	fgetstktop:
+	  begin
+	    load; gencst(op_ads,sz_int); gencst(op_loi,s);
+	    asp:=lsp; ak:=loaded;
+	  end;
+#endif
+	fchr: checkbnds(charptr);
+	fpred, fsucc:
+	  begin genop(b);
+	    if nicescalar(asp) then genrck(asp) else errasp(+0181)
+	  end;
+	fodd:
+	  begin gencst(op_loc,1); asp:=boolptr; genasp(op_and) end;
+	ftrunc, fround: if asp<>realptr then errasp(+0182);
+	fsin: m:=SINX;
+	fcos: m:=COSX;
+	fexp: m:=EXPX;
+	fsqt: m:=SQT;
+	flog: m:=LOG;
+	fatn: m:=ATN;
+	phalt:s:=0;
+	pread, preadln, pwrite, pwriteln, pput, pget: ;
+      end;
+      if m<>CLS then
+	begin gensp(m,s);
+	  if lkey>=feof then genasp(op_lfr)
+	end;
+      if (lkey=fround) or (lkey=ftrunc) then
+	opconvert(ri);
+    end;
+  if lpar then nextif(rparent,+0183);
+end end;
+
+{===================================================================}
+
+procedure convert(fsp:sp; l1:integer);
+{Convert tries to make the operands of some operator of the same type.
+  The operand types are given by fsp and a.asp. The resulting type
+  is put in a.asp.
+  l1 gives the lino of the first instruction of the right operand.
+}
+var l2:integer; ts:twostruct; lsp:sp;
+begin with a do begin asp:=desub(asp);
+  ts:=compat(asp,fsp);
+  case ts of
+    eq,subeq:
+      ;
+    il,ir,lr:
+      opconvert(ts);
+    es:
+      expandnullset(fsp);
+    li,ri,rl,se:
+      begin l2:=newmark; lsp:=asp; asp:=fsp;
+	convert(lsp,l1); exchange(l1,l2); relmark(l2); asp:=lsp
+      end;
+    noteq:
+      errasp(+0184);
+  end;
+  if asp=realptr then fltused:=true
+end end;
+
+procedure buildset(fsys:sos);
+{This is a bad construct in pascal. Two objections:
+  - expr..expr very difficult to implement on most machines
+  - this construct makes it hard to implement sets of different size
+}
+const   ncsb    = 32;   {tunable}
+type    byteset = set of 0..MB1;
+var     i,j,val1,val2,ncst,l1,l2,sz:integer;
+	cst1,cst2,cst12,varpart:boolean;
+	cstpart:array[1..ncsb] of byteset;
+
+procedure genconstset(sz:integer);
+	{level 2: <<  buildset}
+var i,j:integer;
+
+function setcode(s:byteset):byte;
+	{level 3: <<  buildset}
+var b,i,w:byte;
+begin i:=0; w:=0; b:=1;
+  for i:=0 to MB1 do
+    begin if i in s then w:=w+b; b:=b+b end;
+  setcode := w;
+end;
+
+begin
+  i:=sz;
+  repeat
+    genop(op_loc); j:=i; i:=i-sz_word;
+    {the bytes of the next word to be loaded on the stack}
+    {are in cstpart[i+1] .. cstpart[j]}
+    if sz_word=2 then put1(sp_cst2)
+    else put1(sp_cst4);
+    for j:=i+1 to j do put1(setcode(cstpart[j]))
+  until i = 0;
+end;
+
+procedure setexpr(fsys:sos; var c:boolean; var v:integer);
+	{level 2: <<  buildset}
+var min:integer; lsp:sp;
+begin with a do begin c:=false; v:=0; lsp:=asp;
+  expression(fsys); asp:=desub(asp);
+  if not eqstruct(asp,lsp^.elset) then
+    begin error(+0185); lsp:=nullset end;
+  if lsp=nullset then
+    begin
+      if bounded(asp) then bounds(asp,min,sz) else
+	if asp=intptr then sz:=iopt-1 else begin errasp(+0186); sz:=0 end;
+      sz:=sz div NB1 + 1; while sz mod sz_word <> 0 do sz:=sz+1;
+      if sz>sz_mset then errasp(+0187);
+      lsp:=newsp(power,sz); lsp^.elset:=asp
+    end;
+  if asp<>nil then if ak=cst then
+    if (pos.ad<0) or (pos.ad div NB1>=sizeof(lsp,wordmult)) then
+      error(+0188)
+    else if sz<=ncsb*sz_byte then
+      begin c:=true; v:=pos.ad end;
+  if not c then load; asp:=lsp
+end end;
+
+begin with a do begin  {buildset}
+  varpart:=false; ncst:=0; asp:=nullset;
+  for i:=1 to ncsb do cstpart[i]:=[];
+  if find2([notsy..lparent],fsys,+0189) then
+    repeat l1:=newmark;
+      setexpr(fsys+[colon2,comma],cst1,val1); cst12:=cst1;
+      if find3(colon2,fsys+[comma,notsy..lparent],+0190) then
+	begin setexpr(fsys+[comma,notsy..lparent],cst2,val2);
+	  cst12:=cst12 and cst2;
+	  if not cst12 then
+	    begin
+	      if cst2 then gencst(op_loc,val2);
+	      if cst1 then
+		begin l2:=newmark; gencst(op_loc,val1); exchange(l1,l2);
+		  relmark(l2);
+		end;
+	      l2:=newmark; genasp(op_zer); exchange(l1,l2);
+	      relmark(l2);
+	      genasp(op_loc); gensp(BTS,3*sz_word)
+	    end;
+	end
+      else
+	if cst12 then val2:=val1 else genasp(op_set);
+      if cst12 then
+	for i:=val1 to val2 do
+	  begin j:=i div NB1 + 1; ncst:=ncst+1;
+	    cstpart[j]:=cstpart[j] + [i mod NB1]
+	  end
+      else
+	if varpart then genasp(op_ior) else varpart:=true;
+      relmark(l1);
+    until endofloop(fsys,[notsy..lparent],comma,+0191);  {+0192}
+  ak:=loaded;
+  if ncst>0 then
+    begin
+      genconstset(sizeof(asp,wordmult));
+      if varpart then genasp(op_ior);
+    end
+  else
+    if not varpart then genasp(op_zer);  {empty set}
+end end;
+
+procedure factor(fsys: sos);
+var lip:ip; lsp:sp;
+begin with a do begin
+  asp:=nil; packbit:=false; ak:=loaded;
+  if find1([notsy..nilcst,lparent],fsys,+0193) then
+    case sy of
+      ident:
+	begin lip:=searchid([konst,vars,field,func,carrbnd]); insym;
+	  case lip^.klass of
+	    func: {call moves result to top stack}
+	      begin call(fsys,lip); ak:=loaded; packbit:=false end;
+	    konst:
+	      begin asp:=lip^.idtype;
+		if nicescalar(asp) then  {including asp=nil}
+		  begin ak:=cst; pos.ad:=lip^.value end
+		else
+		  begin ak:=ploaded; laedlb(abs(lip^.value));
+		    if asp^.form=scalar then
+		      begin load; if lip^.value<0 then negate end
+		    else
+		      if asp=zeroptr then ak:=loaded
+		  end
+	      end;
+	    field,vars:
+	      selector(fsys,lip,[used]);
+	    carrbnd:
+	      begin lsp:=lip^.idtype; assert formof(lsp,[carray]);
+		descraddr(lsp^.arpos); lsp:=lsp^.inxtype; asp:=desub(lsp);
+		if lip^.next=nil then ak:=ploaded {low bound} else
+		  begin gencst(op_loi,2*sz_int); genasp(op_adi) end;
+		load; checkbnds(lsp);
+	      end;
+	  end  {case}
+	end;
+      intcst:
+	begin asp:=intptr; ak:=cst; pos.ad:=val; insym end;
+      realcst:
+	begin asp:=realptr; ak:=ploaded; laedlb(val); insym end;
+      longcst:
+	begin asp:=longptr; ak:=ploaded; laedlb(val); insym end;
+      charcst:
+	begin asp:=charptr; ak:=cst; pos.ad:=val; insym end;
+      stringcst:
+	begin asp:=stringstruct; laedlb(val); insym;
+	  if asp<>zeroptr then ak:=ploaded;
+	end;
+      nilcst:
+	begin insym; asp:=nilptr; genasp(op_zer); end;
+      lparent:
+	begin insym; expression(fsys+[rparent]); nextif(rparent,+0194) end;
+      notsy:
+	begin insym; factor(fsys); load; genop(op_teq); asp:=desub(asp);
+	  if asp<>boolptr then errasp(+0195)
+	end;
+      lbrack:
+	begin insym; buildset(fsys+[rbrack]); nextif(rbrack,+0196) end;
+    end
+end end;
+
+procedure term(fsys:sos);
+var lsy:symbol; lsp:sp; l1:integer; first:boolean;
+begin with a,b do begin first:=true;
+  factor(fsys+[starsy..andsy]);
+  while find2([starsy..andsy],fsys,+0197) do
+    begin if first then begin load; first:=false end;
+      lsy:=sy; insym; l1:=newmark; lsp:=asp;
+      factor(fsys+[starsy..andsy]); load; convert(lsp,l1);
+      if asp<>nil then
+	case lsy of
+	  starsy:
+	    if (asp=intptr) or (asp=longptr) then genasp(op_mli) else
+	    if asp=realptr then genasp(op_mlf) else
+	    if asp^.form=power then genasp(op_and) else errasp(+0198);
+	  slashsy:
+	    begin
+	      if (asp=intptr) or (asp=longptr) then
+		begin lsp:=asp;
+		  convert(realptr,l1);  {make real of right operand}
+		  convert(lsp,l1);  {make real of left operand}
+		end;
+	      if asp=realptr then genasp(op_dvf) else errasp(+0199);
+	    end;
+	  divsy:
+	    if (asp=intptr) or (asp=longptr) then genasp(op_dvi) else
+	      errasp(+0200);
+	  modsy:
+	    begin
+	      if asp=intptr then gensp(MDI,2*sz_int) else
+	      if asp=longptr then gensp(MDL,2*sz_long) else errasp(+0201);
+	      genasp(op_lfr);
+	    end;
+	  andsy:
+	    if asp=boolptr then genasp(op_and) else errasp(+0202);
+	end; {case}
+	relmark(l1)
+    end {while}
+end end;
+
+procedure simpleexpression(fsys:sos);
+var lsy:symbol; lsp:sp; l1:integer; signed,min,first:boolean;
+begin with a do begin first:=true;
+  signed:=(sy=plussy) or (sy=minsy);
+  if signed then begin min:=sy=minsy; insym end else min:=false;
+  term(fsys + [minsy,plussy,orsy]); lsp:=desub(asp);
+  if signed then
+    if (lsp<>intptr) and (lsp<>realptr) and (lsp<>longptr) then
+      errasp(+0203)
+    else if min then
+      begin load; first:=false; asp:=lsp; negate end;
+  while find2([plussy,minsy,orsy],fsys,+0204) do
+    begin if first then begin load; first:=false end;
+      lsy:=sy; insym; l1:=newmark; lsp:=asp;
+      term(fsys+[minsy,plussy,orsy]); load; convert(lsp,l1);
+      if asp<>nil then
+	case lsy of
+	  plussy:
+	    if (asp=intptr) or (asp=longptr) then genasp(op_adi) else
+	    if asp=realptr then genasp(op_adf) else
+	    if asp^.form=power then genasp(op_ior) else errasp(+0205);
+	  minsy:
+	    if (asp=intptr) or (asp=longptr) then genasp(op_sbi) else
+	    if asp=realptr then genasp(op_sbf) else
+	    if asp^.form=power then begin genasp(op_com); genasp(op_and) end
+	    else errasp(+0206);
+	  orsy:
+	    if asp=boolptr then genasp(op_ior) else errasp(+0207);
+	end; {case}
+	relmark(l1)
+    end {while}
+end end;
+
+procedure expression; { fsys:sos }
+var lsy:symbol; lsp:sp; l1,l2:integer;
+begin with a do begin l1:=newmark;
+  simpleexpression(fsys+[eqsy..insy]);
+  if find2([eqsy..insy],fsys,+0208) then
+    begin lsy:=sy; insym; lsp:=asp; loadcheap; l2:=newmark;
+      simpleexpression(fsys); loadcheap;
+      if lsy=insy then
+	begin
+	  if not formof(asp,[power]) then errasp(+0209) else
+	    if asp=nullset then genasp(op_and) else
+		  {this effectively replaces the word on top of the
+		   stack by the result of the 'in' operator: false }
+	    if not (compat(lsp,asp^.elset) <= subeq) then errasp(+0210) else
+	      begin exchange(l1,l2); genasp(op_inn) end
+	end
+      else
+	begin convert(lsp,l2);
+	  if asp<>nil then
+	    case asp^.form of
+	      scalar:
+		if asp=realptr then genasp(op_cmf) else genasp(op_cmi);
+	      pointer:
+		if (lsy=eqsy) or (lsy=nesy) then genop(op_cmp) else
+		  errasp(+0211);
+	      power:
+		case lsy of
+		  eqsy,nesy: genasp(op_cms);
+		  ltsy,gtsy: errasp(+0212);
+		  lesy:  {'a<=b' equivalent to 'a-b=[]'}
+		    begin genasp(op_com); genasp(op_and); genasp(op_zer);
+		      genasp(op_cms); lsy:=eqsy
+		    end;
+		  gesy:  {'a>=b' equivalent to 'a=a+b'}
+		    begin gencst(op_dup,2*sizeof(asp,wordmult));
+		      genasp(op_asp); genasp(op_ior);
+		      genasp(op_cms); lsy:=eqsy
+		    end
+		end;  {case}
+	      arrays:
+		if string(asp) then
+		  begin gencst(op_loc,asp^.size);
+		    gensp(BCP,2*sz_addr+sz_word);
+		    gencst(op_lfr,sz_word)
+		  end
+		else errasp(+0213);
+	      records: errasp(+0214);
+	      files: errasp(+0215)
+	    end;  { case }
+	  case lsy of
+	    ltsy: genop(op_tlt);
+	    lesy: genop(op_tle);
+	    gtsy: genop(op_tgt);
+	    gesy: genop(op_tge);
+	    nesy: genop(op_tne);
+	    eqsy: genop(op_teq)
+	  end
+	end;
+      relmark(l2);
+      asp:=boolptr; ak:=loaded
+    end;
+    relmark(l1)
+end end;
+
+{===================================================================}
+
+procedure statement(fsys:sos); forward;
+		{this forward declaration can be avoided}
+
+procedure assignment(fsys:sos; fip:ip);
+var la:attr; l1,l2:integer;
+begin
+  l1:=newmark; selector(fsys+[becomes],fip,[assigned]); l2:=newmark;
+  la:=a; nextif(becomes,+0216);
+  expression(fsys); loadcheap; checkasp(la.asp,+0217);
+  exchange(l1,l2); a:=la;
+  relmark(l1); relmark(l2);
+  if not formof(la.asp,[arrays..records]) then store else
+    begin loadaddr;
+      if la.asp^.form<>carray then genasp(op_blm) else
+	begin descraddr(la.asp^.arpos); gensp(ASZ,sz_addr);
+	  gencst(op_lfr,sz_word); gencst(op_bls,sz_word)
+	end;
+    end;
+end;
+
+procedure gotostatement;
+{jumps into structured statements can give strange results. }
+label 1;
+var llp:lp; lbp:bp; diff:integer;
+begin
+  if sy<>intcst then error(+0218) else
+    begin llp:=searchlab(b.lchain,val);
+      if llp<>nil then gencst(op_bra,llp^.labname) else
+	begin lbp:=b.nextbp; diff:=1;
+	  while lbp<>nil do
+	    begin llp:=searchlab(lbp^.lchain,val);
+	      if llp<>nil then goto 1;
+	      lbp:=lbp^.nextbp; diff:=diff+1;
+	    end;
+1:        if llp=nil then errint(+0219,val) else
+	    begin
+	      if llp^.labdlb=0 then
+		begin dlbno:=dlbno+1; llp^.labdlb:=dlbno;
+		  genop(ps_ina); argdlb(dlbno);  {forward data reference}
+		end;
+	      laedlb(llp^.labdlb);
+	      if diff=level-1 then gencst(op_zer,sz_addr) else
+		gencst(op_lxl,diff);
+	      gensp(GTO,2*sz_addr);
+	    end;
+	end;
+      insym;
+    end
+end;
+
+procedure compoundstatement(fsys:sos; err:integer);
+begin
+  repeat statement(fsys+[semicolon])
+  until endofloop(fsys,[beginsy..casesy],semicolon,err)
+end;
+
+procedure ifstatement(fsys:sos);
+var lb1,lb2:integer;
+begin with b do begin
+  expression(fsys+[thensy,elsesy]);
+  force(boolptr,+0220); ilbno:=ilbno+1; lb1:=ilbno; gencst(op_zeq,lb1);
+  nextif(thensy,+0221); statement(fsys+[elsesy]);
+  if find3(elsesy,fsys,+0222) then
+    begin ilbno:=ilbno+1; lb2:=ilbno; gencst(op_bra,lb2);
+      newilb(lb1); statement(fsys); newilb(lb2)
+    end
+  else newilb(lb1);
+end end;
+
+procedure casestatement(fsys:sos);
+label 1;
+type cip=^caseinfo;
+     caseinfo=record
+	next: cip;
+	csstart: integer;
+	cslab: integer
+     end;
+var lsp:sp; head,p,q,r:cip; l0,l1:integer;
+    ilb1,ilb2,dlb,i,n,m,min,max:integer;
+begin with b do begin
+  expression(fsys+[ofsy,semicolon,ident..plussy]); lsp:=a.asp; load;
+  if not nicescalar(desub(lsp)) then begin error(+0223); lsp:=nil end;
+  l0:=newmark; ilbno:=ilbno+1; ilb1:=ilbno;
+  nextif(ofsy,+0224); head:=nil; max:=-MI; min:=MI; n:=0;
+  repeat ilbno:=ilbno+1; ilb2:=ilbno;   {label of current case}
+    repeat i:=cstinteger(fsys+[comma,colon1,semicolon],lsp,+0225);
+      if i>max then max:=i; if i<min then min:=i; n:=n+1;
+      q:=head; r:=nil; new(p);
+      while q<>nil do
+	begin  {chain all cases in ascending order}
+	  if q^.cslab>=i then
+	    begin if q^.cslab=i then error(+0226); goto 1 end;
+	  r:=q; q:=q^.next
+	end;
+1:    p^.next:=q; p^.cslab:=i; p^.csstart:=ilb2;
+      if r=nil then head:=p else r^.next:=p;
+    until endofloop(fsys+[colon1,semicolon],[ident..plussy],comma,+0227);
+    {+0228}
+    nextif(colon1,+0229); newilb(ilb2); statement(fsys+[semicolon]);
+    gencst(op_bra,ilb1);
+  until lastsemicolon(fsys,[ident..plussy],+0230);  {+0231 +0232}
+  assert n<>0; newilb(ilb1); l1:=newmark;
+  dlb:=newdlb; genop(ps_rom); argnil;
+  if (max div 3) - (min div 3) < n then
+    begin argcst(min); argcst(max-min);
+      m:=op_csa;
+      while head<>nil do
+	begin
+	  while head^.cslab>min do
+	    begin argnil; min:=min+1 end;
+	  argilb(head^.csstart); min:=min+1; head:=head^.next
+	end;
+    end
+  else
+    begin argcst(n); m:=op_csb;
+      while head<>nil do
+	begin argcst(head^.cslab);argilb(head^.csstart);head:=head^.next end;
+    end;
+  argend; laedlb(dlb); gencst(m,sz_word); exchange(l0,l1);
+  relmark(l0); relmark(l1)
+end end;
+
+procedure repeatstatement(fsys:sos);
+var lb1: integer;
+begin with b do begin
+  ilbno:=ilbno+1; lb1:=ilbno; newilb(lb1);
+  compoundstatement(fsys+[untilsy],+0233);  {+0234}
+  nextif(untilsy,+0235); genlin;
+  expression(fsys); force(boolptr,+0236); gencst(op_zeq,lb1);
+end end;
+
+procedure whilestatement(fsys:sos);
+var lb1,lb2: integer;
+begin with b do begin
+  ilbno:=ilbno+1; lb1:=ilbno; newilb(lb1);
+  ilbno:=ilbno+1; lb2:=ilbno;
+  genlin; expression(fsys+[dosy]);
+  force(boolptr,+0237); gencst(op_zeq,lb2);
+  nextif(dosy,+0238); statement(fsys);
+  gencst(op_bra,lb1); newilb(lb2)
+end end;
+
+procedure forstatement(fsys:sos);
+var lip:ip; tosym:boolean; endlab,looplab(* ,savlb *):integer;
+    av,at1,at2:attr; lsp:sp;
+
+procedure forbound(fsys:sos; var fa:attr; fsp:sp);
+begin
+  expression(fsys); fa:=a; force(fsp,+0239);
+  if fa.ak<>cst then
+    begin temporary(fsp,reg_any);
+      genasp(op_dup); fa:=a; store
+    end
+end;
+
+begin with b do begin (* savlb:=reglb; *) tosym:=false;
+  ilbno:=ilbno+1; looplab:=ilbno; ilbno:=ilbno+1; endlab:=ilbno;
+  inita(nil,0);
+  if sy<>ident then error(+0240) else
+    begin lip:=searchid([vars]); insym;
+      a.asp:=lip^.idtype; a.pos:=lip^.vpos;
+      lip^.iflag:=lip^.iflag+[used,assigned,loopvar];
+      if level>1 then
+	if (a.pos.ad>=0) or (a.pos.lv<>level) then
+	  error(+0241);
+    end;
+  lsp:=desub(a.asp);
+  if not nicescalar(lsp) then begin errasp(+0242); lsp:=nil end;
+  av:=a; nextif(becomes,+0243);
+  forbound(fsys+[tosy,downtosy,notsy..lparent,dosy],at1,lsp);
+  if find1([tosy,downtosy],fsys+[notsy..lparent,dosy],+0244) then
+    begin tosym:=sy=tosy; insym end;
+  forbound(fsys+[dosy],at2,lsp);
+  if tosym then gencst(op_bgt,endlab) else gencst(op_blt,endlab);
+  a:=at1; force(av.asp,+0245); a:=av; store; newilb(looplab);
+  nextif(dosy,+0246); statement(fsys);
+  a:=av; load; a:=at2; load; gencst(op_beq,endlab);
+  a:=av; load; if tosym then genop(op_inc) else genop(op_dec);
+  a.asp:=lsp; checkbnds(av.asp); a:=av; store;
+  gencst(op_bra,looplab); newilb(endlab);
+  (* reglb:=savlb *)
+end end;
+
+procedure withstatement(fsys:sos);
+var lnp,savtop:np; (* savlb:integer; *) pbit:boolean;
+begin with b do begin
+  (* savlb:=reglb;*) savtop:=top;
+  repeat variable(fsys+[comma,dosy]);
+    if not formof(a.asp,[records]) then errasp(+0247) else
+      begin pbit:=spack in a.asp^.sflag;
+	new(lnp,wrec); lnp^.occur:=wrec; lnp^.fname:=a.asp^.fstfld;
+	if a.ak<>fixed then
+	  begin loadaddr; temporary(nilptr,reg_pointer); store;
+	    a.ak:=pfixed;
+	  end;
+	a.packbit:=pbit; lnp^.wa:=a; lnp^.nlink:=top; top:=lnp;
+      end;
+  until endofloop(fsys+[dosy],[ident],comma,+0248);  {+0249}
+  nextif(dosy,+0250); statement(fsys);
+  top:=savtop; (* reglb:=savlb; *)
+end end;
+
+procedure assertion(fsys:sos);
+begin teststandard;
+  if opt['a']=off then
+    while not (sy in fsys) do insym
+  else
+    begin expression(fsys); force(boolptr,+0251);
+      gencst(op_loc,srcorig); gensp(ASS,2*sz_word);
+    end
+end;
+
+procedure statement; {fsys: sos}
+var lip:ip; llp:lp; lsy:symbol;
+begin
+  assert [labelsy..casesy,endsy] <= fsys;
+  assert [ident,intcst] * fsys = [];
+  if find2([intcst],fsys+[ident],+0252) then
+    begin llp:=searchlab(b.lchain,val);
+      if llp=nil then errint(+0253,val) else
+	begin if llp^.seen then errint(+0254,val) else llp^.seen:=true;
+	  newilb(llp^.labname)
+	end;
+      insym; nextif(colon1,+0255);
+    end;
+  if find2([ident,beginsy..casesy],fsys,+0256) then
+    begin if giveline then if sy<>whilesy then genlin;
+      if sy=ident then
+	if id='assert  ' then
+	  begin insym; assertion(fsys) end
+	else
+	  begin lip:=searchid([vars,field,func,proc]); insym;
+	    if lip^.klass=proc then call(fsys,lip) else assignment(fsys,lip)
+	  end
+      else
+	begin lsy:=sy; insym;
+	  case lsy of
+	    beginsy:
+	      begin compoundstatement(fsys,+0257);  {+0258}
+		nextif(endsy,+0259)
+	      end;
+	    gotosy:
+	      gotostatement;
+	    ifsy:
+	      ifstatement(fsys);
+	    casesy:
+	      begin casestatement(fsys); nextif(endsy,+0260) end;
+	    whilesy:
+	      whilestatement(fsys);
+	    repeatsy:
+	      repeatstatement(fsys);
+	    forsy:
+	      forstatement(fsys);
+	    withsy:
+	      withstatement(fsys);
+	  end
+	end;
+    end
+end;
+
+{===================================================================}
+
+procedure body(fsys:sos; fip:ip);
+var i,dlb,l0,l1,ssp:integer; llp:lp; spset:boolean;
+begin with b do begin
+{produce PRO}
+  genpnam(ps_pro,fip); argend;
+  gencst(ps_mes,ms_par);argcst(fip^.maxlb); argend;
+  l0:=newmark; dlb:=0; trace('procentr',fip,dlb);
+#ifdef  CHL
+  if b.tip<>nil then
+    gencst(op_zrl,-sz_word); {ensure A68BIT=0}
+#endif
+{global labels}
+  llp:=lchain; spset:=false;
+  while llp<>nil do
+    begin
+      if llp^.labdlb<>0 then
+	begin
+	  if not spset then
+	    begin spset:=true;
+	      gencst(ps_mes,ms_gto); argend;
+	      temporary(nilptr,-1); ssp:=a.pos.ad;
+	      gencst(op_lor,1); store
+	    end;
+	  argdlb(llp^.labdlb); lino:=lino+1; genop(ps_rom);
+	  argilb(llp^.labname); argcst(ssp); argend;
+#ifdef CHL
+	  gengotonam(ps_exa,fip,llp^.labname);
+	  genop(ps_rom);argcst(0);argend;
+#endif
+	end;
+      llp:=llp^.nextlp
+    end;
+{the body itself}
+  currproc:=fip;
+  compoundstatement(fsys,+0261);  {+0262}
+  trace('procexit',fip,dlb);
+{undefined labels}
+  llp:=lchain;
+  while llp<>nil do
+    begin if not llp^.seen then errint(+0263,llp^.labval);
+      llp:=llp^.nextlp
+    end;
+{finish and close files}
+  treewalk(top^.fname);
+  if level=1 then
+    begin l1:=newmark;
+      genop(op_fil); argdlb(fildlb);  {temporarily}
+      dlb:=newdlb; gencst(ps_con,argc+1);
+      for i:=0 to argc do with argv[i] do
+	begin argcst(ad);
+	  if (ad=-1) and (i>1) then errid(+0264,name)
+	end;
+      argend; gencst(op_lxl,0); laedlb(dlb); genglb(op_lae,0);
+      gencst(op_lxa,0); gensp(INI,4*sz_addr);
+      exchange(l0,l1); relmark(l1); gencst(op_loc,0); gensp(HLT,0)
+    end
+  else
+    begin inita(fip^.idtype,fip^.pfpos.ad);
+      if fip^.klass=func then
+	begin load;
+	  if not (assigned in fip^.iflag) then
+	    errid(-(+0265),fip^.name)
+	end;
+      genasp(op_ret)
+    end;
+  relmark(l0);
+  gencst(ps_end,-minlb)
+end end;
+
+{===================================================================}
+
+procedure block;  {forward declared}
+begin with b do begin
+  assert [labelsy..withsy] <= fsys;
+  assert [ident,intcst,casesy,endsy,period] * fsys = [];
+  if find3(labelsy,fsys,+0266) then labeldeclaration(fsys);
+  if find3(constsy,fsys,+0267) then constdefinition(fsys);
+  if find3(typesy,fsys,+0268) then typedefinition(fsys);
+  if find3(varsy,fsys,+0269) then vardeclaration(fsys);
+#ifndef CHL 
+  if fip=progp then
+    begin
+      if iop[true]<>nil then
+	begin
+	  argv[1].ad:=posaddr(holeb,textptr,false);
+	  iop[true]^.vpos.ad:=argv[1].ad
+	end;
+      if iop[false]<>nil then
+	begin
+	  argv[0].ad:=posaddr(holeb,textptr,false);
+	  iop[false]^.vpos.ad:=argv[0].ad
+	end;
+      genhol; genpnam(ps_exp,fip);
+    end;  {externals are also extern for the main body}
+#else
+  if not(ioaddressfixed) then {fixup adresses, only once}
+  begin
+    argv[1].ad:=posaddr(holeb,textptr,false);
+    iop[true]^.vpos.ad:=argv[1].ad;
+    argv[0].ad:=posaddr(holeb,textptr,false);
+    iop[false]^.vpos.ad:=argv[0].ad;
+    ioaddressfixed:=true;
+  end;
+  if fip=progp then begin genhol; genpnam(ps_exp,fip) end;
+#endif
+  fip^.pfpos.ad:=negaddr(fip^.idtype);  {function result area}
+  while find2([procsy,funcsy],fsys,+0270) do pfdeclaration(fsys);
+  if forwcount<>0 then error(+0271);  {forw proc not specified}
+  nextif(beginsy,+0272);
+  body(fsys+[casesy,endsy],fip);
+  nextif(endsy,+0273);
+end end;
+
+{===================================================================}
+
+procedure programme(fsys:sos);
+var stdin,stdout:boolean; p:ip;
+begin
+  nextif(progsy,+0274); nextif(ident,+0275);
+  if find3(lparent,fsys+[semicolon],+0276) then
+    begin
+      repeat
+	if sy<>ident then error(+0277) else
+	  begin stdin:=id='input   '; stdout:=id='output  ';
+	    if stdin or stdout then
+	      begin 
+#ifndef CHL
+		p:=newip(vars,id,textptr,nil);
+		enterid(p); iop[stdout]:=p;
+#endif
+	      end
+	    else
+	      if argc<maxargc then
+		begin
+		  argc:=argc+1; argv[argc].name:=id; argv[argc].ad:=-1
+		end;
+	    insym
+	  end
+      until endofloop(fsys+[rparent,semicolon],[ident],comma,+0278);  {+0279}
+      if argc>maxargc then
+	begin error(+0280); argc:=maxargc end;
+      nextif(rparent,+0281);
+    end;
+  nextif(semicolon,+0282);
+  block(fsys,progp);
+  if opt['l']<>off then
+    begin gencst(ps_mes,ms_src); argcst(srcorig); argend end;
+  eofexpected:=true; nextif(period,+0283);
+end;
+
+procedure compile;
+var lsys:sos;
+begin lsys:=[progsy,labelsy..withsy];
+  repeat eofexpected:=false;
+    main:=find2([progsy,labelsy,beginsy..withsy],lsys,+0284);
+#ifdef CHL
+	iop[false]:=newip(vars,'input   ',textptr,nil);
+	enterid(iop[false]);
+	iop[true]:=newip(vars,'output  ',textptr,nil);
+	enterid(iop[true]);
+#endif
+    if main then programme(lsys) else
+      begin
+	if find3(constsy,lsys,+0285) then constdefinition(lsys);
+	if find3(typesy,lsys,+0286) then typedefinition(lsys);
+	if find3(varsy,lsys,+0287) then vardeclaration(lsys);
+#ifdef CHL
+        argv[1].ad:=posaddr(holeb,textptr,false);
+        iop[true]^.vpos.ad:=argv[1].ad;
+        argv[0].ad:=posaddr(holeb,textptr,false);
+        iop[false]^.vpos.ad:=argv[0].ad;
+	ioaddressfixed:=true;
+#endif
+	genhol;
+	while find2([procsy,funcsy],lsys,+0288) do pfdeclaration(lsys);
+      end;
+    error(+0289);
+  until false;  { the only way out is the halt in nextln on eof }
+end;
+
+{===================================================================}
+
+procedure init1;
+var c:char;
+begin
+{reserved words}
+  rw[ 0]:='if      ';   rw[ 1]:='do      ';     rw[ 2]:='of      ';
+  rw[ 3]:='to      ';   rw[ 4]:='in      ';     rw[ 5]:='or      ';
+  rw[ 6]:='end     ';   rw[ 7]:='for     ';     rw[ 8]:='nil     ';
+  rw[ 9]:='var     ';   rw[10]:='div     ';     rw[11]:='mod     ';
+  rw[12]:='set     ';   rw[13]:='and     ';     rw[14]:='not     ';
+  rw[15]:='then    ';   rw[16]:='else    ';     rw[17]:='with    ';
+  rw[18]:='case    ';   rw[19]:='type    ';     rw[20]:='goto    ';
+  rw[21]:='file    ';   rw[22]:='begin   ';     rw[23]:='until   ';
+  rw[24]:='while   ';   rw[25]:='array   ';     rw[26]:='const   ';
+  rw[27]:='label   ';   rw[28]:='repeat  ';     rw[29]:='record  ';
+  rw[30]:='downto  ';   rw[31]:='packed  ';     rw[32]:='program ';
+  rw[33]:='function';   rw[34]:='procedur';
+{corresponding symbols}
+  rsy[ 0]:=ifsy;        rsy[ 1]:=dosy;          rsy[ 2]:=ofsy;
+  rsy[ 3]:=tosy;        rsy[ 4]:=insy;          rsy[ 5]:=orsy;
+  rsy[ 6]:=endsy;       rsy[ 7]:=forsy;         rsy[ 8]:=nilcst;
+  rsy[ 9]:=varsy;       rsy[10]:=divsy;         rsy[11]:=modsy;
+  rsy[12]:=setsy;       rsy[13]:=andsy;         rsy[14]:=notsy;
+  rsy[15]:=thensy;      rsy[16]:=elsesy;        rsy[17]:=withsy;
+  rsy[18]:=casesy;      rsy[19]:=typesy;        rsy[20]:=gotosy;
+  rsy[21]:=filesy;      rsy[22]:=beginsy;       rsy[23]:=untilsy;
+  rsy[24]:=whilesy;     rsy[25]:=arraysy;       rsy[26]:=constsy;
+  rsy[27]:=labelsy;     rsy[28]:=repeatsy;      rsy[29]:=recordsy;
+  rsy[30]:=downtosy;    rsy[31]:=packedsy;      rsy[32]:=progsy;
+  rsy[33]:=funcsy;      rsy[34]:=procsy;
+{indices into rw to find reserved words fast}
+  frw[0]:= 0; frw[1]:= 0; frw[2]:= 6; frw[3]:=15; frw[4]:=22;
+  frw[5]:=28; frw[6]:=32; frw[7]:=33; frw[8]:=35;
+{char types}
+  for c:=chr(0) to chr(maxcharord) do cs[c]:=others;
+  for c:='0' to '9' do cs[c]:=digit;
+  for c:='A' to 'Z' do cs[c]:=upper;
+  for c:='a' to 'z' do cs[c]:=lower;
+  cs[chr(ascnl)]:=layout;
+  cs[chr(ascvt)]:=layout;
+  cs[chr(ascff)]:=layout;
+  cs[chr(asccr)]:=layout;
+{characters with corresponding chartype in ASCII order}
+  cs[chr(ascht)]:=tabch;
+  cs[' ']:=layout;      cs['"']:=dquotech;      cs['''']:=quotech;
+  cs['(']:=lparentch;   cs[')']:=rparentch;     cs['*']:=star;
+  cs['+']:=plusch;      cs[',']:=commach;       cs['-']:=minch;
+  cs['.']:=periodch;    cs['/']:=slash;         cs[':']:=colonch;
+  cs[';']:=semich;      cs['<']:=lessch;        cs['=']:=equal;
+  cs['>']:=greaterch;   cs['[']:=lbrackch;      cs[']']:=rbrackch;
+  cs['^']:=arrowch;     cs['{']:=lbracech;
+{single character symbols in chartype order}
+  csy[rparentch]:=rparent;      csy[lbrackch]:=lbrack;
+  csy[rbrackch]:=rbrack;        csy[commach]:=comma;
+  csy[semich]:=semicolon;       csy[arrowch]:=arrow;
+  csy[plusch]:=plussy;          csy[minch]:=minsy;
+  csy[slash]:=slashsy;          csy[star]:=starsy;
+  csy[equal]:=eqsy;
+{pascal library mnemonics}
+  lmn[ELN ]:='_eln';    lmn[EFL ]:='_efl';      lmn[CLS ]:='_cls';
+  lmn[WDW ]:='_wdw';
+  lmn[OPN ]:='_opn';    lmn[GETX]:='_get';      lmn[RDI ]:='_rdi';
+  lmn[RDC ]:='_rdc';    lmn[RDR ]:='_rdr';      lmn[RDL ]:='_rdl';
+  lmn[RLN ]:='_rln';
+  lmn[CRE ]:='_cre';    lmn[PUTX]:='_put';      lmn[WRI ]:='_wri';
+  lmn[WSI ]:='_wsi';    lmn[WRC ]:='_wrc';      lmn[WSC ]:='_wsc';
+  lmn[WRS ]:='_wrs';    lmn[WSS ]:='_wss';      lmn[WRB ]:='_wrb';
+  lmn[WSB ]:='_wsb';    lmn[WRR ]:='_wrr';      lmn[WSR ]:='_wsr';
+  lmn[WRL ]:='_wrl';    lmn[WSL ]:='_wsl';
+  lmn[WRF ]:='_wrf';    lmn[WRZ ]:='_wrz';      lmn[WSZ ]:='_wsz';
+  lmn[WLN ]:='_wln';    lmn[PAG ]:='_pag';
+  lmn[ABR ]:='_abr';    lmn[RND ]:='_rnd';      lmn[SINX]:='_sin';
+  lmn[COSX]:='_cos';    lmn[EXPX]:='_exp';      lmn[SQT ]:='_sqt';
+  lmn[LOG ]:='_log';    lmn[ATN ]:='_atn';      lmn[ABI ]:='_abi';
+  lmn[ABL ]:='_abl';
+  lmn[BCP ]:='_bcp';    lmn[BTS ]:='_bts';      lmn[NEWX]:='_new';
+  lmn[SAV ]:='_sav';    lmn[RST ]:='_rst';      lmn[INI ]:='_ini';
+  lmn[HLT ]:='_hlt';    lmn[ASS ]:='_ass';      lmn[GTO ]:='_gto';
+  lmn[PAC ]:='_pac';    lmn[UNP ]:='_unp';      lmn[DIS ]:='_dis';
+  lmn[ASZ ]:='_asz';    lmn[MDI ]:='_mdi';      lmn[MDL ]:='_mdl';
+{scalar variables}
+  b.nextbp:=nil;
+  b.reglb:=0;
+  b.minlb:=0;
+  b.ilbno:=0;
+  b.forwcount:=0;
+  b.lchain:=nil;
+#ifdef  CHL
+  b.tip:=nil;
+#endif
+  srcchno:=0;
+  srclino:=1;
+  srcorig:=1;
+  lino:=0;
+  dlbno:=0;
+#ifdef CHL
+  dlbno:=dlbno+1;
+  glbdata:=dlbno;
+  holdone := true; {until inits done}
+#endif
+  holeb:=0;
+  argc:=1;
+  lastpfno:=0;
+  giveline:=true;
+  including:=false;
+  eofexpected:=false;
+  intypedec:=false;
+  fltused:=false;
+  seconddot:=false;
+#ifdef CHL
+  ioaddressfixed:=false;
+#endif
+  iop[false]:=nil;
+  iop[true]:=nil;
+  argv[0].ad:=-1;
+  argv[1].ad:=-1;
+#ifdef NO_EXC
+  ohead := nil;
+  bcnt := 0;
+  mhead := nil;
+#endif NO_EXC
+end;
+
+procedure init2;
+var p:ip; k:idclass; j:standpf;
+    pfn:array[standpf] of idarr;
+begin
+{initialize the first name space}
+  new(top,blck); top^.occur:=blck; top^.nlink:=nil; top^.fname:=nil;
+  level:=0;
+{undefined identifier pointers used by searchid}
+  for k:=types to func do
+    undefip[k]:=newip(k,spaces,nil,nil);
+{names of standard procedures/functions}
+  pfn[pread     ]:='read    ';  pfn[preadln     ]:='readln  ';
+  pfn[pwrite    ]:='write   ';  pfn[pwriteln    ]:='writeln ';
+  pfn[pput      ]:='put     ';  pfn[pget        ]:='get     ';
+  pfn[ppage     ]:='page    ';  pfn[preset      ]:='reset   ';
+  pfn[prewrite  ]:='rewrite ';  pfn[pnew        ]:='new     ';
+  pfn[pdispose  ]:='dispose ';  pfn[ppack       ]:='pack    ';
+  pfn[punpack   ]:='unpack  ';  pfn[pmark       ]:='mark    ';
+  pfn[prelease  ]:='release ';  pfn[phalt       ]:='halt    ';
+#ifdef  CHL
+  pfn[penew     ]:='enew    ';  pfn[pedispose   ]:='edispose';
+  pfn[psetstktop]:='setstkto';  pfn[pmoveleft   ]:='moveleft';
+  pfn[fgetstktop]:='getstkto';  pfn[fasptr      ]:='asptr   ';
+  pfn[fincptr   ]:='incptr  ';
+#endif
+  pfn[feof      ]:='eof     ';  pfn[feoln       ]:='eoln    ';
+  pfn[fabs      ]:='abs     ';  pfn[fsqr        ]:='sqr     ';
+  pfn[ford      ]:='ord     ';  pfn[fchr        ]:='chr     ';
+  pfn[fpred     ]:='pred    ';  pfn[fsucc       ]:='succ    ';
+  pfn[fodd      ]:='odd     ';  pfn[ftrunc      ]:='trunc   ';
+  pfn[fround    ]:='round   ';  pfn[fsin        ]:='sin     ';
+  pfn[fcos      ]:='cos     ';  pfn[fexp        ]:='exp     ';
+  pfn[fsqt      ]:='sqrt    ';  pfn[flog        ]:='ln      ';
+  pfn[fatn      ]:='arctan  ';
+{standard procedure/function identifiers}
+  for j:=pread to phalt do
+    begin new(p,proc,standard); p^.klass:=proc;
+      p^.name:=pfn[j]; p^.pfkind:=standard; p^.key:=j; enterid(p);
+    end;
+  for j:=feof to fatn do
+    begin new(p,func,standard); p^.klass:=func; p^.idtype:=nil;
+      p^.name:=pfn[j]; p^.pfkind:=standard; p^.key:=j; enterid(p);
+    end;
+{program identifier}
+  progp:=newip(proc,'m_a_i_n ',nil,nil);
+end;
+
+procedure init3;
+var n:np; p,q:ip; i:integer; c:char;
+#if EM_WSIZE == 2
+    is:packed array[1..imax] of char;
+#endif
+begin
+  for i:=0 to sz_last do readln(errors,sizes[i]);
+  if sz_int  = 2 then maxintstring  := max2bytes
+  else		      maxintstring  := max4bytes;
+  if sz_long = 2 then maxlongstring := max2bytes
+  else		      maxlongstring := max4bytes;
+  gencst(ps_mes,ms_emx); argcst(sz_word); argcst(sz_addr); argend;
+  ix:=1;
+  while not eoln(errors) do
+    begin read(errors,c);
+      if ix<smax then begin strbuf[ix]:=c; ix:=ix+1 end
+    end;
+  readln(errors); strbuf[ix]:=chr(0);
+  for i:=1 to fnmax do
+    if i<ix then source[i]:=strbuf[i] else source[i]:=' ';
+  fildlb:=romstr(sp_scon,0);
+{standard type pointers}
+  intptr :=newsp(scalar,sz_int);
+  realptr:=newsp(scalar,sz_real);
+  longptr:=newsp(scalar,sz_long);
+  charptr:=newsp(scalar,sz_char);
+  boolptr:=newsp(scalar,sz_bool);
+  nilptr :=newsp(pointer,sz_addr);
+  zeroptr:=newsp(pointer,sz_addr);
+  procptr:=newsp(records,sz_proc);
+  nullset:=newsp(power,sz_word); nullset^.elset:=nil;
+  textptr:=newsp(files,sz_head+sz_buff); textptr^.filtype:=charptr;
+{standard type names}
+  enterid(newip(types,'integer ',intptr,nil));
+  enterid(newip(types,'real    ',realptr,nil));
+  enterid(newip(types,'char    ',charptr,nil));
+  enterid(newip(types,'boolean ',boolptr,nil));
+  enterid(newip(types,'text    ',textptr,nil));
+{standard constant names}
+  q:=nil; p:=newip(konst,'false   ',boolptr,q); enterid(p);
+  q:=p; p:=newip(konst,'true    ',boolptr,q); p^.value:=1; enterid(p);
+  boolptr^.fconst:=p;
+{maxint of the target machine}
+  p:=newip(konst,'maxint  ',intptr,nil);
+  if sz_int = 2 then p^.value:=MI2
+  else 
+#if EM_WSIZE == 4
+	p^.value := MI;
+#else
+  {EM_WSIZE = 2, sz_int = 4}
+    begin p^.idtype:=longptr; ix:=imax; is:=max4bytes;
+      for i:=1 to ix do strbuf[i]:=is[i];
+      p^.value:=romstr(sp_icon,sz_int);
+    end;
+#endif
+  enterid(p);
+  p:=newip(konst,spaces,charptr,nil); p^.value:=maxcharord;
+  charptr^.fconst:=p;
+{new name space for user externals}
+  new(n,blck); n^.occur:=blck; n^.nlink:=top; n^.fname:=nil; top:=n;
+{options}
+  for c:='a' to 'z' do begin opt[c]:=0; forceopt[c]:=false end;
+  opt['a']:=on;
+  opt['i']:=NB1*sz_iset;
+  opt['l']:=on;
+  opt['o']:=on;
+  opt['r']:=on;
+#ifdef CHL
+  opt['g']:=on;
+  opt['w']:=on;
+  holdone := false;
+#endif
+  sopt:=off;
+end;
+
+procedure init4;
+begin
+  copt:=opt['c'];
+  dopt:=opt['d']; if EM_WSIZE < sz_int then dopt:=on;
+  iopt:=opt['i'];
+  sopt:=opt['s'];
+  if sopt<>off then begin copt:=off; dopt:=off end
+  else if opt['u']<>off then cs['_']:=lower;
+  if copt<>off then enterid(newip(types,'string  ',zeroptr,nil));
+  if dopt<>off then enterid(newip(types,'long    ',longptr,nil));
+  if opt['o']=off then begin gencst(ps_mes,ms_opt); argend end;
+  if dopt<>off then fltused:=true;  {temporary kludge}
+end;
+
+begin  {main body of pcompiler}
+  init1;  {initialize tables and scalars}
+  init2;  {initialize heap objects}
+  rewrite(em); put2(sp_magic); reset(errors);
+  init3;  {size dependent initialization}
+  while not eof(errors) do
+    begin options(false); readln(errors) end;
+  rewrite(errors);
+  if not eof(input) then
+    begin nextch; insym;
+      init4;  {option dependent initialization}
+      compile
+    end;
+#ifdef STANDARD
+9999: ;
+#endif
+end.  {pcompiler}