1	0    0:d    1  { This item is the property of SofTech Microsystems, Inc.,      }
    2	0    0:d    1  { and it may be used, copied or distrubuted only as permitted   }
    3	0    0:d    1  { in a written license from that company.		       }
    4	0    0:d    1  
    5	0    0:d    1  { This is an unpublished work copyright 1977,1978,1979 by The   }
    6	0    0:d    1  { Regents of the University of California and 1980, 1981,       }
    7	0    0:d    1  { 1982, 1983 by SofTech Microsystems, Inc.		       }
    8	0    0:d    1  
    9	0    0:d    1  {$C Copr (c) 1977,78,79 Regents,UC and 1980,81,82,83 SMS	  }
   10	0    0:d    1  
   11	0    0:d    1  
   12	0    0:d    1  (*{$I #17:head.text}*)
   13	0    0:d    1  
   14	2    1:d    1  unit error_handler;
   15	2    1:d    1  
   16	2    1:d    1	 {  Passed the error number, error_handler passes back the string 
   17	2    1:d    1	    in msg (an empty string means no message available). This unit
   18	2    1:d    1	    may need changes when system.syntax is modified.
   19	2    1:d    1	 }
   20	2    1:d    1  
   21	2    1:d    1  interface
   22	2    1:d    1	
   23	2    1:d    1	 procedure putsyntax(var msg:string; errnum:integer);
   24	2    1:d    1  
   25	2    1:d    1  implementation
   26	2    1:d    1	 
   27	2    1:d    1	 procedure putsyntax;
   28	2    2:d    1	 const
   29	2    2:d    1	   eol = 13; dle = 16; maxchar = 128;
   30	2    2:d    1	 
   31	2    2:d    1	 VAR
   32	2    2:d    1	   msglength,D0,D1,D2,BLK,PTR,COLON: INTEGER;
   33	2    2:d    8	   T,C:PACKED ARRAY [0..2] OF CHAR;
   34	2    2:d   12	   BUF:PACKED ARRAY [0..1023] OF CHAR;
   35	2    2:d  524	   F: FILE;
   36	2    2:d  564	 
   37	2    2:d  564	 PROCEDURE PUTNUM;
   38	2    3:0    0	 BEGIN
   39	2    3:1    0	   msg := '';
   40	2    2:0    0	 END;
   41	2    2:0    0	 
   42	2    2:0    0	 BEGIN (* putsyntax *)
   43	2    2:1   10	   reset(F,'*SYSTEM.SYNTAX');
   44	2    2:1   24	   { This code assumes that system.syntax remains unchanged.  This hard-
   45	2    2:1   24	     wired index allows both the editor and the compiler to do only one
   46	2    2:1   24	     disk read to get to the text of the error message }
   47	2    2:1   24	   IF (errnum < 0) or (errnum > 409) or (IORESULT<>0) THEN PUTNUM
   48	2    2:1   47	   ELSE
   49	2    2:2   52	     BEGIN
   50	2    2:3   52	       IF ERRNUM<=101 THEN BLK:=2
   51	2    2:3   60	       ELSE
   52	2    2:4   64		 IF ERRNUM<=125 THEN BLK:=4
   53	2    2:4   72		 ELSE
   54	2    2:5   76		   IF ERRNUM<=150 THEN BLK:=6
   55	2    2:5   84		   ELSE
   56	2    2:6   88		     IF ERRNUM<=183 THEN BLK:=8
   57	2    2:6   96		     ELSE
   58	2    2:7  100		      IF ERRNUM<=259 THEN BLK:=10
   59	2    2:7  109		      ELSE BLK:=12;
   60	2    2:3  115	       if BLOCKREAD(F,BUF,2,BLK)<>2 THEN PUTNUM
   61	2    2:3  132	       ELSE
   62	2    2:4  137		 BEGIN
   63	2    2:5  137		   IF BUF[0]=CHR(DLE) THEN PTR:=2 ELSE PTR:=0;
   64	2    2:5  155		   D0:=ERRNUM DIV 100; (* convert error number to characters *)
   65	2    2:5  162		   D1:=(ERRNUM-D0*100) DIV 10;
   66	2    2:5  173		   D2:=ERRNUM MOD 10;
   67	2    2:5  183		   T[0]:=CHR(D0+ORD('0')); T[1]:=CHR(D1+ORD('0'));
   68	2    2:5  205		   T[2]:=CHR(D2+ORD('0'));
   69	2    2:5  216		   REPEAT
   70	2    2:6  216		     FILLCHAR(C,3,'0');
   71	2    2:6  223		     COLON:=SCAN(3,=':',BUF[PTR]);
   72	2    2:6  240		     MOVELEFT(BUF[PTR],C[3-COLON],COLON);
   73	2    2:6  258		     COLON:=COLON+PTR;
   74	2    2:6  262		     PTR:=SCAN(MAXCHAR,=CHR(EOL),BUF[PTR])+PTR+3
   75	2    2:5  280		   UNTIL (T=C) OR (BUF[PTR-2]=CHR(0));
   76	2    2:5  306		   IF T<>C THEN PUTNUM
   77	2    2:5  315		   ELSE
   78	2    2:6  319		     BEGIN
   79	2    2:7  319		       if (ptr-colon)-4 < 80 then
   80	2    2:8  329			 msglength := (ptr-colon) - 4 
   81	2    2:7  332		       else
   82	2    2:8  337			 msglength := 80;
   83	2    2:7  340		       msg[0] := chr(msglength);
   84	2    2:7  347		       MOVELEFT(BUF[COLON+1],MSG[1],msglength);
   85	2    2:6  364		     END
   86	2    2:4  364		 END
   87	2    2:2  364	       END(* if ioresult<>0 *);
   88	2    1:0    0	 END(* putsyntax *);
   89	2    1:0    0	 
   90	2     :0    0  end.

End of Compilation.