Check-in [e0844d3905]

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:Added missing comment closing brace (pint.pas)
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1:e0844d390517a2b72a77e07ee567def702bd7163
User & Date: tonypdmtr 2014-10-20 11:05:19
Context
2016-11-20
22:13
Updated to 5th version of the Pascal-P compiler -- pascal-p5 check-in: 3c37614ec4 user: tonypdmtr tags: trunk
2014-10-20
11:05
Added missing comment closing brace (pint.pas) check-in: e0844d3905 user: tonypdmtr tags: trunk
2014-10-16
09:22
P5 Pascal Compiler upgrade check-in: ec0b3dba13 user: tonyp tags: trunk
Changes

Changes to pint.pas.

107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
...
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
...
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
...
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
...
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
...
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
...
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
...
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
...
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
...
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
...
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
...
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
...
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
...
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
....
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
....
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
....
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
....
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
....
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
....
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
....
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
....
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
....
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
....
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
....
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
....
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
....
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
....
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
....
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
....
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
....
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
....
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
....
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
....
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
....
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
....
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
....
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
....
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
....
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
....
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
....
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
....
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
....
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
*                 that if the associated file is in read mode, the delayed     *
*                 read to the buffer variable occurs. The file address remains *
*                 on the stack.                                                *
*                                                                              *
* ipj v l ip jmp: Interprocedure jump. Contains the level of the target        *
*                 procedure, and the label to jump to. The stack is adjusted   *
*                 to remove all nested procedures/functions, then the label is *
*                 unconditionally jumped to.                                   *        
*                                                                              *
* cip p           Call indirect procedure/function. The top of stack has the   *
*                 address of a mp/address pair pushed by lpa. The dl of the    *
*                 current mark is replaced by the mp, and the address replaces *
*                 the current pc. The mp/ad address is removed from stack.     *
*                                                                              *
* lpa p l q       Load procedure address. The current mark pointer is loaded   *
................................................................................
label 1;

const

      {

      Program object sizes and characteristics, sync with pint. These define
      the machine specific characteristics of the target. 
      
      This configuration is for a 32 bit machine as follows:

      integer               32  bits
      real                  64  bits
      char                  8   bits
      boolean               8   bits
      set                   256 bits
................................................................................
      setsize     =       32;  { size of set }
      setal       =        1;  { alignment of set }
      filesize    =        1;  { required runtime space for file (lfn) }
      fileidsize  =        1;  { size of the lfn only }
      stackal     =        4;  { alignment of stack }
      stackelsize =        4;  { stack element size }
      maxsize     =       32;  { this is the largest type that can be on the stack }
      { Heap alignment should be either the natural word alignment of the 
        machine, or the largest object needing alignment that will be allocated.
        It can also be used to enforce minimum block allocation policy. }
      heapal      =        4;  { alignment for each heap arena }
      sethigh     =      255;  { Sets are 256 values }
      setlow      =        0;
      ordmaxchar  =      255;  { Characters are 8 bit ISO/IEC 8859-1 }
      ordminchar  =        0;
................................................................................
        addresses, since the startup code is at least that long. }
      nilval      =        1;  { value of 'nil' }

      { end of pcom and pint common parameters }

      { internal constants }

      { !!! Need to use the small size memory to self compile, otherwise, by 
        definition, pint cannot fit into its own memory. }
      {elide}maxstr      = 16777215;{noelide}  { maximum size of addressing for program/var }
      {remove maxstr     =  2000000; remove}  { maximum size of addressing for program/var }
      maxdigh     = 6;       { number of digits in hex representation of maxstr }
      maxdigd     = 8;       { number of digits in decimal representation of maxstr }

      codemax     = maxstr;  { set size of code store to maximum possible }
................................................................................

      { assigned logical channels for header files }
      inputfn    = 1;        { 'input' file no. }
      outputfn   = 2;        { 'output' file no. }
      prdfn      = 3;        { 'prd' file no. }
      prrfn      = 4;        { 'prr' file no. }

      { Mark element offsets 

        Mark format is:

        0:  Function return value, 64 bits, enables a full real result.
        8:  Static link.
        12: Dynamic link.
        16: Saved EP from previous frame.
................................................................................
      dotrcsrc    = false;    { trace source line executions (requires dosrclin) }
      dodmpspc    = false;    { dump heap space after execution }
      dorecycl    = true;     { obey heap space recycle requests }
      { We can perform limited checking for attempts to access freed heap
        blocks, but only if we don't recycle them, because this moves the header
        information around. It is "limited" because there is nothing to prevent
        the program from holding the address of a data item within the block
        past a dispose. }                      
      dochkrpt    = false;    { check reuse of freed entry (automatically 
                                invokes dorecycl = false }

      { version numbers }
    
      majorver   = 1; { major version number }
      minorver   = 0; { minor version number }
                
type
      { These equates define the instruction layout. I have choosen a 32 bit
        layout for the instructions defined by (4 bit) digit:

           byte 0:   Instruction code
           byte 1:   P parameter
           byte 2-5: Q parameter
................................................................................

          true:  (i: integer);
          false: (b: packed array [1..intsize] of byte);

       end;
    i: 1..intsize;

begin 

   for i := 1 to intsize do r.b[i] := store[a+i-1];

   getint := r.i 

end;

procedure putint(a: address; x: integer); 

var r: record case boolean of

          true:  (i: integer);
          false: (b: packed array [1..intsize] of byte);

       end;
    i: 1..intsize;

begin 

   r.i := x;
   for i := 1 to intsize do store[a+i-1] := r.b[i]

end;

function getrel(a: address): real;
................................................................................

       end;
    i: 1..realsize;

begin

   for i := 1 to realsize do r.b[i] := store[a+i-1];
   getrel := r.r 

end;

procedure putrel(a: address; f: real);

var r: record case boolean of

................................................................................

       end;
    i: 1..setsize;

begin

   for i := 1 to setsize do r.b[i] := store[a+i-1];
   s := r.s 

end;

procedure putset(a: address; s: settype);

var r: record case boolean of

................................................................................

       end;
    i: 1..adrsize;

begin

   for i := 1 to adrsize do r.b[i] := store[a+i-1];
   getadr := r.a 

end;

procedure putadr(a: address; ad: address);

var r: record case boolean of

................................................................................
   { load up the second on stack }
   for i := 1 to l do sb[i] := store[sp-adrsize-l+i-1];
   putadr(sp-adrsize-l, p); { place pointer at bottom }
   for i := 1 to l do store[sp-l+i-1] := sb[i] { place second as new top }

end;

{ end of accessor functions

(*--------------------------------------------------------------------*)

{ Push/pop

  These routines handle both the data type, and their lengths on the stack.

................................................................................

begin

   { fetch instruction from byte store }
   ads := ad;
   op := store[ad]; ad := ad+1;
   if insp[op] then begin p := store[ad]; ad := ad+1 end;
   if insq[op] > 0 then begin 

      case insq[op] of

         1:        q := store[ad];
         intsize:  q := getint(ad);

      end;
      ad := ad+insq[op] 

   end;
   write(': ');
   wrthex(op, 2);
   write(' ', instr[op]:10, '  ');
   if insp[op] then begin

      wrthex(p, 2);
      if insq[op] > 0 then begin write(','); wrthex(q, maxdigh) end

   end else if insq[op] > 0 then begin write('   '); wrthex(q, maxdigh) end

end; 

{ dump contents of instruction memory }

procedure dmpins;

var i:  address;

................................................................................
      wrthex(i, maxdigh);
      lstins(i);
      writeln

   end;
   writeln

end; 

{ align address, upwards }

procedure alignu(algn: address; var flc: address);
  var l: integer;
begin
  l := flc-1;
................................................................................
        iline: integer; { line number of intermediate file }

   procedure init;
      var i: integer;
   begin for i := 0 to maxins do instr[i] := '          ';
         {

           Notes: 

           1. Instructions marked with "*" are for internal use only.
              The "*" mark both shows in the listing, and also prevents
              their use in the intermediate file, since only alpha
              characters are allowed as opcode labels.

           2. "---" entries are no longer used, but left here to keep the
              original instruction numbers from P4. They could be safely
              assigned to other instructions if the space is needed.

         }
         instr[  0]:='lodi      '; insp[  0] := true;  insq[  0] := intsize;     
         instr[  1]:='ldoi      '; insp[  1] := false; insq[  1] := intsize;
         instr[  2]:='stri      '; insp[  2] := true;  insq[  2] := intsize;     
         instr[  3]:='sroi      '; insp[  3] := false; insq[  3] := intsize;
         instr[  4]:='lda       '; insp[  4] := true;  insq[  4] := intsize;     
         instr[  5]:='lao       '; insp[  5] := false; insq[  5] := intsize;
         instr[  6]:='stoi      '; insp[  6] := false; insq[  6] := 0;
         instr[  7]:='ldc       '; insp[  7] := false; insq[  7] := intsize;
         instr[  8]:='---       '; insp[  8] := false; insq[  8] := 0;
         instr[  9]:='indi      '; insp[  9] := false; insq[  9] := intsize;
         instr[ 10]:='inci      '; insp[ 10] := false; insq[ 10] := intsize;
         instr[ 11]:='mst       '; insp[ 11] := true;  insq[ 11] := 0;
................................................................................
         if labeltab[i].st = entered then writeln('Entered')
         else writeln('Defined')

      end;
      writeln

   end;
   
   procedure update(x: labelrg); (*when a label definition lx is found*)
      var curr,succ,ad: address; (*resp. current element and successor element
                               of a list of future references*)
          endlist: boolean;
          op: instyp; q : address;  (*instruction register*)
   begin
      if labeltab[x].st=defined then errorl('duplicated label         ')
................................................................................
      var x: integer; (* label number *)
          again: boolean;
   begin
      again := true;
      while again do
            begin if eof(prd) then errorl('unexpected eof on input  ');
                  getnxt;(* first character of line*)
                  if not (ch in ['i', 'l', 'q', ' ', '!', ':']) then 
                    errorl('unexpected line start    ');
                  case ch of
                       'i': getlin;
                       'l': begin read(prd,x);
                                  getnxt;
                                  if ch='=' then read(prd,labelvalue)
                                            else labelvalue:= pc;
................................................................................
                                  update(x); getlin
                            end;
                       'q': begin again := false; getlin end;
                       ' ': begin getnxt; assemble end;
                       ':': begin { source line }

                               read(prd,x); { get source line number }
                               if dosrclin then begin 

                                  { pass source line register instruction } 
                                  store[pc] := 174; pc := pc+1;
                                  putint(pc, x); pc := pc+intsize

                               end;
                               { skip the rest of the line, which would be the
                                 contents of the source line if included }
                               while not eoln(prd) do
................................................................................
         var x: labelrg;
      begin while (ch<>'l') and not eoln(prd) do read(prd,ch);
            read(prd,x); lookup(x)
      end;(*labelsearch*)

      procedure getname;
      var i: alfainx;
      begin 
        if eof(prd) then errorl('unexpected eof on input  ');
        for i := 1 to maxalfa do word[i] := ' ';
        i := 1; { set 1st character of word }
        while ch in ['a'..'z'] do begin
          if i = maxalfa then errorl('Opcode label is too long ');
          word[i] := ch;
          i := i+1; ch := ' ';
          if not eoln(prd) then read(prd,ch); { next character }
        end;
        pack(word,1,name) 
      end; (*getname*)

      procedure storeop;
      begin
        if pc+1 > cp then errorl('Program code overflow    ');
        store[pc] := op; pc := pc+1
      end;
................................................................................
      while (instr[op]<>name) and (op < maxins) do op := op+1;
      if op = maxins then errorl('illegal instruction      ');

      case op of  (* get parameters p,q *)

          (*lod,str,lda,lip*)
          0, 105, 106, 107, 108, 109,
          2, 70, 71, 72, 73, 74,4,120: begin read(prd,p,q); storeop; storep; 
                                             storeq
                                       end;

          { [sam] There is a compiler bug with reads to restricted range 
            variables in IP Pascal here. }
          12(*cup*): begin read(prd,t{p}); p := t; labelsearch; storeop; 
                           storep; storeq
                     end;

          11,113(*mst,cip*): begin read(prd,p); storeop; storep end;

          { equm,neqm,geqm,grtm,leqm,lesm take a parameter }
          142, 148, 154, 160, 166, 172,
................................................................................
          (*ents,ente*)
          13, 173: begin labelsearch; storeop; storeq end;

          (*ipj,lpa*)
          112,114: begin read(prd,p); labelsearch; storeop; storep; storeq end;

          15 (*csp*): begin skpspc; getname;
                           while name<>sptable[q] do 
                           begin q := q+1; if q > maxsp then 
                                 errorl('std proc/func not found  ')
                           end;
                           storeop; storeq
                      end;

          7, 123, 124, 125, 126, 127 (*ldc*): begin case op of  (*get q*)
                           123: begin read(prd,i); storeop; 
                                      if pc+intsize > cp then 
                                         errorl('Program code overflow    ');
                                      putint(pc, i); pc := pc+intsize
                                end;

                           124: begin read(prd,r); 
                                      cp := cp-realsize;
                                      alignd(realal, cp);
                                      if cp <= 0 then 
                                         errorl('constant table overflow  ');
                                      putrel(cp, r); q := cp;
                                      storeop; storeq
                                end;

                           125: storeop; (*p,q = 0*)

                           126: begin read(prd,q); storeop; 
                                      if pc+1 > cp then 
                                        errorl('Program code overflow    ');
                                      putbol(pc, q <> 0); pc := pc+1 end;

                           127: begin
                                  skpspc;
                                  if ch <> '''' then
                                    errorl('illegal character        ');
                                  getnxt;  c := ch;
                                  getnxt;
                                  if ch <> '''' then
                                    errorl('illegal character        ');
                                  storeop; 
                                  if pc+1 > cp then 
                                    errorl('Program code overflow    ');
                                  putchr(pc, c); pc := pc+1
                                end;
                           7: begin skpspc; 
                                   if ch <> '(' then errorl('ldc() expected           ');
                                   s := [ ];  getnxt;
                                   while ch<>')' do
                                   begin read(prd,s1); getnxt; s := s + [s1]
                                   end;
                                   cp := cp-setsize;
                                   alignd(setal, cp);
................................................................................
                     end;

           26, 95, 96, 97, 98, 99 (*chk*): begin
                         read(prd,lb,ub);
                         if op = 95 then q := lb
                         else
                         begin
                           cp := cp-intsize; 
                           alignd(intal, cp);
                           if cp <= 0 then errorl('constant table overflow  ');
                           putint(cp, ub);
                           cp := cp-intsize; 
                           alignd(intal, cp);
                           if cp <= 0 then errorl('constant table overflow  ');
                           putint(cp, lb); q := cp
                         end;
                         storeop; storeq
                       end;

................................................................................
                           end
                         until c = '''';
                         { place in storage }
                         cp := cp-l;
                         if cp <= 0 then errorl('constant table overflow  ');
                         q := cp;
                         for x := 1 to l do putchr(q+x-1, str[x]);
                         { this should have worked, the for loop is faulty 
                           because the calculation for end is done after the i
                           set
                         for i := 0 to i-1 do putchr(q+i, str[i+1]);
                         }
                         storeop; storeq
                       end;

................................................................................
          22, 167, 168, 169, 170, 171,

          59, 133, 134, 135, 136, (*ord*)

          6, 80, 81, 82, 83, 84, (*sto*)

          { eof,adi,adr,sbi,sbr,sgs,flt,flo,trc,ngi,ngr,sqi,sqr,abi,abr,not,and,
            ior,dif,int,uni,inn,mod,odd,mpi,mpr,dvi,dvr,stp,chr,rnd,rgs,fbv, 
            fvb }
          27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,
          48,49,50,51,52,53,54,58,60,62,110,111,
          115, 116: storeop;

                      (*ujc must have same length as ujp, so we output a dummy
                        q argument*)
................................................................................
   if dodmpsto then begin { dump storage overview }

      writeln;
      writeln('Storage areas occupied');
      writeln;
      write('Program     '); wrthex(0, maxdigh); write('-'); wrthex(pctop-1, maxdigh);
      writeln(' (',pctop:maxdigd,')');
      write('Stack/Heap  '); wrthex(pctop, maxdigh); write('-'); wrthex(cp-1, maxdigh); 
      writeln(' (',cp-pctop+1:maxdigd,')');
      write('Constants   '); wrthex(cp, maxdigh); write('-'); wrthex(maxstr, maxdigh); 
      writeln(' (',maxstr-(cp):maxdigd,')');
      writeln

   end;
   if dodmpins then dmpins; { Debug: dump instructions from store }
   if dodmplab then dmplabs { Debug: dump label definitions }

................................................................................
      writeln;
      write('pc = '); wrthex(pc-1, maxdigh);
      write(' op = ',op:3);
      write(' sp = '); wrthex(sp, maxdigh);
      write(' mp = '); wrthex(mp, maxdigh);
      write(' np = '); wrthex(np, maxdigh);
      write(' cp = '); wrthex(cp, maxdigh);
      writeln; 
      write('------------------------------------------------------------');
      writeln('-------------');

      writeln;
      writeln('Stack');
      writeln;
      s := sp; i := 0;
................................................................................
   if store[fa] = 0 then begin { no file }
     if fa = pctop+inputoff then ff := inputfn
     else if fa = pctop+outputoff then ff := outputfn
     else if fa = pctop+prdoff then ff := prdfn
     else if fa = pctop+prroff then ff := prrfn
     else begin
       i := 5; { start search after the header files }
       ff := 0; 
       while i <= maxfil do begin 
         if filstate[i] = fclosed then begin ff := i; i := maxfil end;
         i := i+1 
       end;
       if ff = 0 then errori('To many files            ');
     end;
     store[fa] := ff
   end
end;

................................................................................
begin
   writeln;
   writeln('Heap space breakdown');
   writeln;
   ad := np; { index the bottom of heap }
   while ad < cp do begin
      l := getadr(ad); { get next block length }
      write('addr: '); wrthex(ad, maxdigh); write(': ', abs(l):6, ': '); 
      if l >= 0 then writeln('free') else writeln('alloc');
      ad := ad+abs(l)
   end
end;

{ find free block using length }

................................................................................
     l := getadr(blk); { get length }
     if l >= len+adrsize then begin b := blk; blk := cp end { found }
     else blk := blk+abs(l) { go next block }
  end;
  if b > 0 then begin { block was found }
     putadr(b, -(len+adrsize)); { allocate block }
     blk := b+adrsize; { set base address }
     if l > len+adrsize+adrsize+resspc then begin 
        { If there is enough room for the block, header, and another header,
          then a reserve factor if desired. }
        b := b+len+adrsize; { go to top of allocated block }
        putadr(b, l-(len+adrsize)) { set length of stub space }
     end
  end else blk := 0 { set no block found }
end;
................................................................................

procedure cscspc;
var done: boolean;
    ad, ad1, l, l1: address;
begin
   { first, colapse all free blocks at the heap bottom }
   done := false;
   while not done and (np < cp) do begin 
      l := getadr(np); { get header length }
      if l >= 0 then np := np+getadr(np) { free, skip block }
      else done := true { end }
   end;
   { now, walk up and collapse adjacent free blocks }
   ad := np; { index bottom }
   while ad < cp do begin
      l := getadr(ad); { get header length }
      if l >= 0 then begin { free }
         ad1 := ad+l; { index next block }
         if ad1 < cp then begin { not against end }
            l1 := getadr(ad1); { get length next }
            if l1 >=0 then 
               putadr(ad, l+l1) { both blocks are free, combine the blocks }
            else ad := ad+l+abs(l1) { skip both blocks }
         end else ad := ad+l+abs(l1) { skip both blocks }
      end else ad := ad+abs(l) { skip this block }
   end
end;

................................................................................
     alignd(heapal, ad); { align to arena }
     len := len+(ad1-ad); { adjust length upwards for alignment }
     if ad <= ep then errori('store overflow           ');
     np:= ad;
     putadr(ad, -(len+adrsize)); { allocate block }
     blk := ad+adrsize { index start of block }
  end
end; 

{ dispose of space in heap }

procedure dspspc(len, blk: address);
var ad: address;
begin
   len := len; { shut up compiler check }
................................................................................

   procedure putfile(var f: text; var ad: address);
   begin f^:= getchr(ad+fileidsize); put(f)
   end;(*putfile*)

begin (*callsp*)
      if q > maxsp then errori('invalid std proc/func    ');
        
      { trace routine executions }
      if dotrcrot then writeln(pc:6, '/', sp:6, '-> ', q:2);
      
      case q of
           0 (*get*): begin popadr(ad); valfil(ad); fn := store[ad];
                           if fn <= prrfn then case fn of
                              inputfn: getfile(input);
                              outputfn: errori('get on output file       ');
                              prdfn: getfile(prd);
                              prrfn: errori('get on prr file          ')
................................................................................
                              prrfn: writeln(prr)
                           end else begin
                                if filstate[fn] <> fwrite then
                                   errori('File not in write mode   ');
                                writeln(filtable[fn])
                           end
                      end;
           6 (*wrs*): begin popint(l); popint(w); popadr(ad1); 
                           popadr(ad); pshadr(ad); valfil(ad); fn := store[ad];
                           if fn <= prrfn then case fn of
                              inputfn: errori('write on input file      ');
                              outputfn: writestr(output, ad1, w, l);
                              prdfn: errori('write on prd file        ');
                              prrfn: writestr(prr, ad1, w, l)
                           end else begin
................................................................................
                           if fn <= prrfn then case fn of
                                 inputfn: line:= eoln(input);
                                 outputfn: errori('eoln output file         ');
                                 prdfn: line:=eoln(prd);
                                 prrfn: errori('eoln on prr file         ')
                              end
                           else begin
                                if filstate[fn] <> fread then 
                                   errori('File not in read mode    ');
                                line:=eoln(filtable[fn])
                           end;
                           pshint(ord(line))
                      end;
           8 (*wri*): begin popint(w); popint(i); popadr(ad); pshadr(ad); 
                            valfil(ad); fn := store[ad];
                           if fn <= prrfn then case fn of
                                 inputfn: errori('write on input file      ');
                                 outputfn: write(output, i:w);
                                 prdfn: errori('write on prd file        ');
                                 prrfn: write(prr, i:w)
                              end
                           else begin
                                if filstate[fn] <> fwrite then
                                   errori('File not in write mode   ');
                                write(filtable[fn], i:w)
                           end
                      end;
           9 (*wrr*): begin popint(w); poprel(r); popadr(ad); pshadr(ad); 
                            valfil(ad); fn := store[ad];
                           if fn <= prrfn then case fn of
                                 inputfn: errori('write on input file      ');
                                 outputfn: write(output, r: w);
                                 prdfn: errori('write on prd file        ');
                                 prrfn: write(prr, r:w)
                              end
                           else begin
                                if filstate[fn] <> fwrite then
                                   errori('File not in write mode   ');
                                write(filtable[fn], r:w)
                           end;
                      end;
           10(*wrc*): begin popint(w); popint(i); c := chr(i); popadr(ad); 
                            pshadr(ad); valfil(ad); fn := store[ad];
                           if fn <= prrfn then case fn of
                                 inputfn: errori('write on input file      ');
                                 outputfn: write(output, c:w);
                                 prdfn: errori('write on prd file        ');
                                 prrfn: write(prr, c:w)
                              end
                           else begin
                                if filstate[fn] <> fwrite then
                                   errori('File not in write mode   ');
                                write(filtable[fn], c:w)
                           end
                      end;
           11(*rdi*): begin popadr(ad1); popadr(ad); pshadr(ad); valfil(ad); 
                            fn := store[ad];
                           if fn <= prrfn then case fn of
                                 inputfn: begin readi(input, i); putint(ad1, i) end;
                                 outputfn: errori('read on output file      ');
                                 prdfn: begin readi(prd, i); putint(ad1, i) end;
                                 prrfn: errori('read on prr file         ')
                              end
                           else begin
                                if filstate[fn] <> fread then
                                   errori('File not in read mode    ');
                                readi(filtable[fn], i);
                                putint(ad1, i) 
                           end
                      end;
           12(*rdr*): begin popadr(ad1); popadr(ad); pshadr(ad); valfil(ad); 
                            fn := store[ad];
                           if fn <= prrfn then case fn of
                                 inputfn: begin readr(input, r); putrel(ad1, r) end;
                                 outputfn: errori('read on output file      ');
                                 prdfn: begin readr(prd, r); putrel(ad1, r) end;
                                 prrfn: errori('read on prr file         ')
                              end
................................................................................
                           else begin
                                if filstate[fn] <> fread then
                                   errori('File not in read mode    ');
                                readr(filtable[fn], r);
                                putrel(ad1, r)
                           end
                      end;
           13(*rdc*): begin popadr(ad1); popadr(ad); pshadr(ad); valfil(ad); 
                            fn := store[ad];
                           if fn <= prrfn then case fn of
                                 inputfn: begin readc(input, c); putchr(ad1, c) end;
                                 outputfn: errori('read on output file      ');
                                 prdfn: begin readc(prd, c); putchr(ad1, c) end;
                                 prrfn: errori('read on prr file         ')
                              end
................................................................................
                      end;
           22(*rsf*): begin popadr(ad); valfil(ad); fn := store[ad];
                           if fn <= prrfn then case fn of
                                inputfn: errori('reset on input file      ');
                                outputfn: errori('reset on output file     ');
                                prdfn: reset(prd);
                                prrfn: errori('reset on prr file        ')
                              end 
                           else begin
                                filstate[fn] := fread;
                                reset(filtable[fn]);
                           end
                      end;
           23(*rwf*): begin popadr(ad); valfil(ad); fn := store[ad];
                           if fn <= prrfn then case fn of
                                inputfn: errori('rewrite on input file    ');
                                outputfn: errori('rewrite on output file   ');
                                prdfn: errori('rewrite on prd file      ');
                                prrfn: rewrite(prr)
                              end 
                           else begin
                                filstate[fn] := fwrite;
                                rewrite(filtable[fn]);
                           end
                      end;
           24(*wrb*): begin popint(w); popint(i); b := i <> 0; popadr(ad); 
                            pshadr(ad); valfil(ad); fn := store[ad];
                           if fn <= prrfn then case fn of
                                 inputfn: errori('write on input file      ');
                                 outputfn: write(output, b:w);
                                 prdfn: errori('write on prd file        ');
                                 prrfn: write(prr, b:w)
                              end 
                           else begin
                                if filstate[fn] <> fwrite then
                                   errori('File not in write mode   ');
                                write(filtable[fn], b:w)
                           end
                      end;
           25(*wrf*): begin popint(f); popint(w); poprel(r); popadr(ad); pshadr(ad);
                            valfil(ad); fn := store[ad];
                           if fn <= prrfn then case fn of
                                 inputfn: errori('write on input file      ');
                                 outputfn: write(output, r:w:f);
                                 prdfn: errori('write on prd file        ');
                                 prrfn: write(prr, r:w:f)
                              end 
                           else begin
                                if filstate[fn] <> fwrite then
                                   errori('File not in write mode   ');
                                write(filtable[fn], r:w:f) 
                           end
                      end;
           26(*dsp*): begin
                           popadr(ad1); popadr(ad); dspspc(ad1, getadr(ad))
                      end;
           27(*wbf*): begin popint(l); popadr(ad1); popadr(ad);
                           valfilwm(ad); fn := store[ad];
................................................................................
                      end;
           28(*wbi*): begin popint(i); popadr(ad); pshadr(ad); pshint(i);
                            valfilwm(ad); fn := store[ad];
                            for i := 1 to intsize do
                               write(bfiltable[fn], store[sp-intsize+i-1]);
                            popint(i)
                      end;
           29(*wbr*): begin poprel(r); popadr(ad); pshadr(ad); pshrel(r); 
                            valfilwm(ad); fn := store[ad];
                            for i := 1 to realsize do 
                               write(bfiltable[fn], store[sp-realsize+i-1]);
                            poprel(r)
                      end;
           30(*wbc*): begin popint(i); c := chr(i); popadr(ad); pshadr(ad); pshint(i); 
                            valfilwm(ad); fn := store[ad];
                            for i := 1 to charsize do
                               write(bfiltable[fn], store[sp-intsize+i-1]);
                            popint(i)
                      end;
           31(*wbb*): begin popint(i); popadr(ad); pshadr(ad); pshint(i); 
                            valfilwm(ad); fn := store[ad];
                            for i := 1 to boolsize do
                               write(bfiltable[fn], store[sp-intsize+i-1]);
                            popint(i)
                      end;
           32(*rbf*): begin popint(l); popadr(ad1); popadr(ad); pshadr(ad);
                            valfilrm(ad); fn := store[ad];
................................................................................
    { fetch instruction from byte store }
    pcs := pc; { save starting pc }
    getop;

    (*execute*)

    { trace executed instructions }
    if dotrcins then begin 

       wrthex(pcs, maxdigh);
       write('/');
       wrthex(sp, maxdigh);
       lstins(pcs);
       writeln

................................................................................
          68 (*ldob*): begin getq; pshint(ord(getbol(pctop+q))) end;
          69 (*ldoc*): begin getq; pshint(ord(getchr(pctop+q))) end;

          2  (*stri*): begin getp; getq; popint(i); putint(base(p)+q, i) end;
          70 (*stra*): begin getp; getq; popadr(ad); putadr(base(p)+q, ad) end;
          71 (*strr*): begin getp; getq; poprel(r1); putrel(base(p)+q, r1) end;
          72 (*strs*): begin getp; getq; popset(s1); putset(base(p)+q, s1) end;
          73 (*strb*): begin getp; getq; popint(i1); b1 := i1 <> 0; 
                             putbol(base(p)+q, b1) end;
          74 (*strc*): begin getp; getq; popint(i1); c1 := chr(i1);
                             putchr(base(p)+q, c1) end;

          3  (*sroi*): begin getq; popint(i); putint(pctop+q, i); end;
          75 (*sroa*): begin getq; popadr(ad); putadr(pctop+q, ad); end;
          76 (*sror*): begin getq; poprel(r1); putrel(pctop+q, r1); end;
................................................................................
          4 (*lda*): begin getp; getq; pshadr(base(p)+q) end;
          5 (*lao*): begin getq; pshadr(pctop+q) end;

          6  (*stoi*): begin popint(i); popadr(ad); putint(ad, i) end;
          80 (*stoa*): begin popadr(ad1); popadr(ad); putadr(ad, ad1) end;
          81 (*stor*): begin poprel(r1); popadr(ad); putrel(ad, r1) end;
          82 (*stos*): begin popset(s1); popadr(ad); putset(ad, s1) end;
          83 (*stob*): begin popint(i1); b1 := i1 <> 0; popadr(ad); 
                             putbol(ad, b1) end;
          84 (*stoc*): begin popint(i1); c1 := chr(i1); popadr(ad); 
                             putchr(ad, c1) end;

          127 (*ldcc*): begin pshint(ord(getchr(pc))); pc := pc+1 end;
          126 (*ldcb*): begin pshint(ord(getbol(pc))); pc := pc+1 end;
          123 (*ldci*): begin i := getint(pc); pc := pc+intsize; pshint(i) end;
          125 (*ldcn*): pshadr(nilval) (* load nil *) ;
          124 (*ldcr*): begin getq; pshrel(getrel(q)) end;
................................................................................
          170 { less }: errori('set inclusion            ');
          172 { lesm }: begin getq; compare; pshint(ord(not b and (store[a1+i] < store[a2+i]))) end;

          23 (*ujp*): begin getq; pc := q end;
          24 (*fjp*): begin getq; popint(i); if i = 0 then pc := q end;
          25 (*xjp*): begin getq; popint(i1); pc := i1*ujplen+q end;

          95 (*chka*): begin getq; popadr(a1); pshadr(a1); 
                             {     0 = assign pointer including nil
                               Not 0 = assign pointer from heap address }
                             if a1 = 0 then  
                                { if zero, but not nil, it's never been assigned }
                                errori('uninitialized pointer    ')
                             else if (q <> 0) and (a1 = nilval) then
                                { q <> 0 means deref, and it was nil 
                                  (which is not zero) }
                                errori('Dereference of nil ptr   ')
                             else if ((a1 < np) or (a1 >= cp)) and 
                                     (a1 <> nilval) then
                                { outside heap space (which could have 
                                  contracted!) }
                                errori('bad pointer value        ')
                             else if dochkrpt and (a1 <> nilval) then begin
                                { perform use of freed space check }
                                if isfree(a1) then
                                   { attempt to dereference or assign a freed 
                                     block }
                                   errori('Ptr used after dispose op')
                             end
                       end;
          96 (*chkr*),
          97 (*chks*): errori('Instruction error        ');
          98 (*chkb*),
          99 (*chkc*),
          26 (*chki*): begin getq; popint(i1); pshint(i1); 
                        if (i1 < getint(q)) or (i1 > getint(q+intsize)) then
                        errori('value out of range       ')
                      end;

          27 (*eof*): begin popadr(ad); valfil(ad); fn := store[ad];
                            if fn <= prrfn then case fn of
                               inputfn: pshint(ord(eof(input)));
                               prdfn: pshint(ord(eof(prd)));
                               outputfn,
                               prrfn: errori('eof test on output file  ')
                            end else begin 
                               if filstate[fn] = fwrite then pshint(ord(true))
                               else if filstate[fn] = fread then 
                                  pshint(ord(eof(filtable[fn]) and not filbuff[fn]))
                               else errori('file is not open         ')
                            end
                      end;

          28 (*adi*): begin popint(i2); popint(i1); pshint(i1+i2) end;
          29 (*adr*): begin poprel(r2); poprel(r1); pshrel(r1+r2) end;
................................................................................
          36 (*ngi*): begin popint(i1); pshint(-i1) end;
          37 (*ngr*): begin poprel(r1); pshrel(-r1) end;
          38 (*sqi*): begin popint(i1); pshint(sqr(i1)) end;
          39 (*sqr*): begin poprel(r1); pshrel(sqr(r1)) end;
          40 (*abi*): begin popint(i1); pshint(abs(i1)) end;
          41 (*abr*): begin poprel(r1); pshrel(abs(r1)) end;
          42 (*not*): begin popint(i1); b1 := i1 <> 0; pshint(ord(not b1)) end;
          43 (*and*): begin popint(i2); b2 := i2 <> 0; 
                            popint(i1); b1 := i1 <> 0; 
                            pshint(ord(b1 and b2)) end;
          44 (*ior*): begin popint(i2); b2 := i2 <> 0; 
                            popint(i1); b1 := i1 <> 0; 
                            pshint(ord(b1 or b2)) end;
          45 (*dif*): begin popset(s2); popset(s1); pshset(s1-s2) end;
          46 (*int*): begin popset(s2); popset(s1); pshset(s1*s2) end;
          47 (*uni*): begin popset(s2); popset(s1); pshset(s1+s2) end;
          48 (*inn*): begin popset(s1); popint(i1); pshint(ord(i1 in s1)) end;
          49 (*mod*): begin popint(i2); popint(i1); pshint(i1 mod i2) end;
          50 (*odd*): begin popint(i1); pshint(ord(odd(i1))) end;
          51 (*mpi*): begin popint(i2); popint(i1); pshint(i1*i2) end;
          52 (*mpr*): begin poprel(r2); poprel(r1); pshrel(r1*r2) end;
          53 (*dvi*): begin popint(i2); popint(i1); 
                            if i2 = 0 then errori('Zero divide              ');
                            pshint(i1 div i2) end;
          54 (*dvr*): begin poprel(r2); poprel(r1); 
                            if r2 = 0.0 then errori('Zero divide              ');
                            pshrel(r1/r2) end;
          55 (*mov*): begin getq; popint(i2); popint(i1);
                       for i3 := 0 to q-1 do store[i1+i3] := store[i2+i3]
                       (* q is a number of storage units *)
                      end;
          56 (*lca*): begin getq; pshadr(q) end;
................................................................................
                      popadr(ad); pshadr(ad); valfilrm(ad); fn := store[ad];
                      { eof is file eof, and buffer not full }
                      pshint(ord(eof(bfiltable[fn]) and not filbuff[fn]))
                     end;
          116 (*fvb*): begin popint(i); popadr(ad); pshadr(ad); valfil(ad);
                      fn := store[ad];
                      { load buffer only if in read mode, and buffer is empty }
                      if (filstate[fn] = fread) and not filbuff[fn] then begin 
                        for j := 1 to i do
                          read(bfiltable[fn], store[ad+fileidsize+j-1]);
                        filbuff[fn] := true
                      end
                    end;
          117 (*dmp*): begin getq; sp := sp-q end; { remove top of stack }

................................................................................
          119 (*tjp*): begin getq; popint(i); if i <> 0 then pc := q end;

          120 (*lip*): begin getp; getq; ad := base(p) + q;
                        i := getadr(ad); a1 := getadr(ad+1*ptrsize);
                        pshadr(i); pshadr(a1)
                      end;

          174 (*mrkl*): begin getq; srclin := q; 
                              if dotrcsrc then 
                                writeln('Source line executed: ', q:1)
                        end;

          { illegal instructions }
          8,   121, 122, 175, 176, 177, 178,
          180, 181, 182, 183, 184, 185, 186, 187, 188, 189,
          190, 191, 192, 193, 194, 195, 196, 197, 198, 199,
          200, 201, 202, 203, 204, 205, 206, 207, 208, 209,
          210, 211, 212, 213, 214, 215, 216, 217, 218, 219,
          220, 221, 222, 223, 224, 225, 226, 227, 228, 229,
          230, 231, 232, 233, 234, 235, 236, 237, 238, 239,
          240, 241, 242, 243, 244, 245, 246, 247, 248, 249,
          250, 251, 252, 253, 254, 
          255: errori('illegal instruction      ');

    end
  end; (*while interpreting*)

  { perform heap dump if requested }
  if dodmpspc then repspc;







|







 







|
|







 







|







 







|







 







|







 







|
|



|


|







 







|



|



|









|







 







|







 







|







 







|







 







|







 







|







|












|







 







|







 







|











|

|

|







 







|







 







|







 







|

|







 







|









|







 







|



|

|







 







|
|






|
|




|


|







|
|











|
|



|







 







|



|







 







|







 







|







 







|

|







 







|







 







|
|

|







 







|







 







|







 







|












|







 







|







 







|


|







 







|







 







|





|













|













|













|











|


|







 







|







 







|











|





|






|













|



|







 







|

|



|





|







 







|







 







|







 







|

|







 







|


|



|


|

|





|








|










|

|







 







|
|

|
|









|


|







 







|







 







|
|












|







107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
...
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
...
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
...
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
...
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
...
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
...
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
...
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
...
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
...
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
...
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
...
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
...
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
...
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
....
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
....
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
....
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
....
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
....
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
....
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
....
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
....
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
....
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
....
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
....
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
....
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
....
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
....
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
....
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
....
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
....
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
....
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
....
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
....
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
....
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
....
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
....
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
....
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
....
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
....
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
....
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
....
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
....
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
*                 that if the associated file is in read mode, the delayed     *
*                 read to the buffer variable occurs. The file address remains *
*                 on the stack.                                                *
*                                                                              *
* ipj v l ip jmp: Interprocedure jump. Contains the level of the target        *
*                 procedure, and the label to jump to. The stack is adjusted   *
*                 to remove all nested procedures/functions, then the label is *
*                 unconditionally jumped to.                                   *
*                                                                              *
* cip p           Call indirect procedure/function. The top of stack has the   *
*                 address of a mp/address pair pushed by lpa. The dl of the    *
*                 current mark is replaced by the mp, and the address replaces *
*                 the current pc. The mp/ad address is removed from stack.     *
*                                                                              *
* lpa p l q       Load procedure address. The current mark pointer is loaded   *
................................................................................
label 1;

const

      {

      Program object sizes and characteristics, sync with pint. These define
      the machine specific characteristics of the target.

      This configuration is for a 32 bit machine as follows:

      integer               32  bits
      real                  64  bits
      char                  8   bits
      boolean               8   bits
      set                   256 bits
................................................................................
      setsize     =       32;  { size of set }
      setal       =        1;  { alignment of set }
      filesize    =        1;  { required runtime space for file (lfn) }
      fileidsize  =        1;  { size of the lfn only }
      stackal     =        4;  { alignment of stack }
      stackelsize =        4;  { stack element size }
      maxsize     =       32;  { this is the largest type that can be on the stack }
      { Heap alignment should be either the natural word alignment of the
        machine, or the largest object needing alignment that will be allocated.
        It can also be used to enforce minimum block allocation policy. }
      heapal      =        4;  { alignment for each heap arena }
      sethigh     =      255;  { Sets are 256 values }
      setlow      =        0;
      ordmaxchar  =      255;  { Characters are 8 bit ISO/IEC 8859-1 }
      ordminchar  =        0;
................................................................................
        addresses, since the startup code is at least that long. }
      nilval      =        1;  { value of 'nil' }

      { end of pcom and pint common parameters }

      { internal constants }

      { !!! Need to use the small size memory to self compile, otherwise, by
        definition, pint cannot fit into its own memory. }
      {elide}maxstr      = 16777215;{noelide}  { maximum size of addressing for program/var }
      {remove maxstr     =  2000000; remove}  { maximum size of addressing for program/var }
      maxdigh     = 6;       { number of digits in hex representation of maxstr }
      maxdigd     = 8;       { number of digits in decimal representation of maxstr }

      codemax     = maxstr;  { set size of code store to maximum possible }
................................................................................

      { assigned logical channels for header files }
      inputfn    = 1;        { 'input' file no. }
      outputfn   = 2;        { 'output' file no. }
      prdfn      = 3;        { 'prd' file no. }
      prrfn      = 4;        { 'prr' file no. }

      { Mark element offsets

        Mark format is:

        0:  Function return value, 64 bits, enables a full real result.
        8:  Static link.
        12: Dynamic link.
        16: Saved EP from previous frame.
................................................................................
      dotrcsrc    = false;    { trace source line executions (requires dosrclin) }
      dodmpspc    = false;    { dump heap space after execution }
      dorecycl    = true;     { obey heap space recycle requests }
      { We can perform limited checking for attempts to access freed heap
        blocks, but only if we don't recycle them, because this moves the header
        information around. It is "limited" because there is nothing to prevent
        the program from holding the address of a data item within the block
        past a dispose. }
      dochkrpt    = false;    { check reuse of freed entry (automatically
                                invokes dorecycl = false }

      { version numbers }

      majorver   = 1; { major version number }
      minorver   = 0; { minor version number }

type
      { These equates define the instruction layout. I have choosen a 32 bit
        layout for the instructions defined by (4 bit) digit:

           byte 0:   Instruction code
           byte 1:   P parameter
           byte 2-5: Q parameter
................................................................................

          true:  (i: integer);
          false: (b: packed array [1..intsize] of byte);

       end;
    i: 1..intsize;

begin

   for i := 1 to intsize do r.b[i] := store[a+i-1];

   getint := r.i

end;

procedure putint(a: address; x: integer);

var r: record case boolean of

          true:  (i: integer);
          false: (b: packed array [1..intsize] of byte);

       end;
    i: 1..intsize;

begin

   r.i := x;
   for i := 1 to intsize do store[a+i-1] := r.b[i]

end;

function getrel(a: address): real;
................................................................................

       end;
    i: 1..realsize;

begin

   for i := 1 to realsize do r.b[i] := store[a+i-1];
   getrel := r.r

end;

procedure putrel(a: address; f: real);

var r: record case boolean of

................................................................................

       end;
    i: 1..setsize;

begin

   for i := 1 to setsize do r.b[i] := store[a+i-1];
   s := r.s

end;

procedure putset(a: address; s: settype);

var r: record case boolean of

................................................................................

       end;
    i: 1..adrsize;

begin

   for i := 1 to adrsize do r.b[i] := store[a+i-1];
   getadr := r.a

end;

procedure putadr(a: address; ad: address);

var r: record case boolean of

................................................................................
   { load up the second on stack }
   for i := 1 to l do sb[i] := store[sp-adrsize-l+i-1];
   putadr(sp-adrsize-l, p); { place pointer at bottom }
   for i := 1 to l do store[sp-l+i-1] := sb[i] { place second as new top }

end;

{ end of accessor functions }

(*--------------------------------------------------------------------*)

{ Push/pop

  These routines handle both the data type, and their lengths on the stack.

................................................................................

begin

   { fetch instruction from byte store }
   ads := ad;
   op := store[ad]; ad := ad+1;
   if insp[op] then begin p := store[ad]; ad := ad+1 end;
   if insq[op] > 0 then begin

      case insq[op] of

         1:        q := store[ad];
         intsize:  q := getint(ad);

      end;
      ad := ad+insq[op]

   end;
   write(': ');
   wrthex(op, 2);
   write(' ', instr[op]:10, '  ');
   if insp[op] then begin

      wrthex(p, 2);
      if insq[op] > 0 then begin write(','); wrthex(q, maxdigh) end

   end else if insq[op] > 0 then begin write('   '); wrthex(q, maxdigh) end

end;

{ dump contents of instruction memory }

procedure dmpins;

var i:  address;

................................................................................
      wrthex(i, maxdigh);
      lstins(i);
      writeln

   end;
   writeln

end;

{ align address, upwards }

procedure alignu(algn: address; var flc: address);
  var l: integer;
begin
  l := flc-1;
................................................................................
        iline: integer; { line number of intermediate file }

   procedure init;
      var i: integer;
   begin for i := 0 to maxins do instr[i] := '          ';
         {

           Notes:

           1. Instructions marked with "*" are for internal use only.
              The "*" mark both shows in the listing, and also prevents
              their use in the intermediate file, since only alpha
              characters are allowed as opcode labels.

           2. "---" entries are no longer used, but left here to keep the
              original instruction numbers from P4. They could be safely
              assigned to other instructions if the space is needed.

         }
         instr[  0]:='lodi      '; insp[  0] := true;  insq[  0] := intsize;
         instr[  1]:='ldoi      '; insp[  1] := false; insq[  1] := intsize;
         instr[  2]:='stri      '; insp[  2] := true;  insq[  2] := intsize;
         instr[  3]:='sroi      '; insp[  3] := false; insq[  3] := intsize;
         instr[  4]:='lda       '; insp[  4] := true;  insq[  4] := intsize;
         instr[  5]:='lao       '; insp[  5] := false; insq[  5] := intsize;
         instr[  6]:='stoi      '; insp[  6] := false; insq[  6] := 0;
         instr[  7]:='ldc       '; insp[  7] := false; insq[  7] := intsize;
         instr[  8]:='---       '; insp[  8] := false; insq[  8] := 0;
         instr[  9]:='indi      '; insp[  9] := false; insq[  9] := intsize;
         instr[ 10]:='inci      '; insp[ 10] := false; insq[ 10] := intsize;
         instr[ 11]:='mst       '; insp[ 11] := true;  insq[ 11] := 0;
................................................................................
         if labeltab[i].st = entered then writeln('Entered')
         else writeln('Defined')

      end;
      writeln

   end;

   procedure update(x: labelrg); (*when a label definition lx is found*)
      var curr,succ,ad: address; (*resp. current element and successor element
                               of a list of future references*)
          endlist: boolean;
          op: instyp; q : address;  (*instruction register*)
   begin
      if labeltab[x].st=defined then errorl('duplicated label         ')
................................................................................
      var x: integer; (* label number *)
          again: boolean;
   begin
      again := true;
      while again do
            begin if eof(prd) then errorl('unexpected eof on input  ');
                  getnxt;(* first character of line*)
                  if not (ch in ['i', 'l', 'q', ' ', '!', ':']) then
                    errorl('unexpected line start    ');
                  case ch of
                       'i': getlin;
                       'l': begin read(prd,x);
                                  getnxt;
                                  if ch='=' then read(prd,labelvalue)
                                            else labelvalue:= pc;
................................................................................
                                  update(x); getlin
                            end;
                       'q': begin again := false; getlin end;
                       ' ': begin getnxt; assemble end;
                       ':': begin { source line }

                               read(prd,x); { get source line number }
                               if dosrclin then begin

                                  { pass source line register instruction }
                                  store[pc] := 174; pc := pc+1;
                                  putint(pc, x); pc := pc+intsize

                               end;
                               { skip the rest of the line, which would be the
                                 contents of the source line if included }
                               while not eoln(prd) do
................................................................................
         var x: labelrg;
      begin while (ch<>'l') and not eoln(prd) do read(prd,ch);
            read(prd,x); lookup(x)
      end;(*labelsearch*)

      procedure getname;
      var i: alfainx;
      begin
        if eof(prd) then errorl('unexpected eof on input  ');
        for i := 1 to maxalfa do word[i] := ' ';
        i := 1; { set 1st character of word }
        while ch in ['a'..'z'] do begin
          if i = maxalfa then errorl('Opcode label is too long ');
          word[i] := ch;
          i := i+1; ch := ' ';
          if not eoln(prd) then read(prd,ch); { next character }
        end;
        pack(word,1,name)
      end; (*getname*)

      procedure storeop;
      begin
        if pc+1 > cp then errorl('Program code overflow    ');
        store[pc] := op; pc := pc+1
      end;
................................................................................
      while (instr[op]<>name) and (op < maxins) do op := op+1;
      if op = maxins then errorl('illegal instruction      ');

      case op of  (* get parameters p,q *)

          (*lod,str,lda,lip*)
          0, 105, 106, 107, 108, 109,
          2, 70, 71, 72, 73, 74,4,120: begin read(prd,p,q); storeop; storep;
                                             storeq
                                       end;

          { [sam] There is a compiler bug with reads to restricted range
            variables in IP Pascal here. }
          12(*cup*): begin read(prd,t{p}); p := t; labelsearch; storeop;
                           storep; storeq
                     end;

          11,113(*mst,cip*): begin read(prd,p); storeop; storep end;

          { equm,neqm,geqm,grtm,leqm,lesm take a parameter }
          142, 148, 154, 160, 166, 172,
................................................................................
          (*ents,ente*)
          13, 173: begin labelsearch; storeop; storeq end;

          (*ipj,lpa*)
          112,114: begin read(prd,p); labelsearch; storeop; storep; storeq end;

          15 (*csp*): begin skpspc; getname;
                           while name<>sptable[q] do
                           begin q := q+1; if q > maxsp then
                                 errorl('std proc/func not found  ')
                           end;
                           storeop; storeq
                      end;

          7, 123, 124, 125, 126, 127 (*ldc*): begin case op of  (*get q*)
                           123: begin read(prd,i); storeop;
                                      if pc+intsize > cp then
                                         errorl('Program code overflow    ');
                                      putint(pc, i); pc := pc+intsize
                                end;

                           124: begin read(prd,r);
                                      cp := cp-realsize;
                                      alignd(realal, cp);
                                      if cp <= 0 then
                                         errorl('constant table overflow  ');
                                      putrel(cp, r); q := cp;
                                      storeop; storeq
                                end;

                           125: storeop; (*p,q = 0*)

                           126: begin read(prd,q); storeop;
                                      if pc+1 > cp then
                                        errorl('Program code overflow    ');
                                      putbol(pc, q <> 0); pc := pc+1 end;

                           127: begin
                                  skpspc;
                                  if ch <> '''' then
                                    errorl('illegal character        ');
                                  getnxt;  c := ch;
                                  getnxt;
                                  if ch <> '''' then
                                    errorl('illegal character        ');
                                  storeop;
                                  if pc+1 > cp then
                                    errorl('Program code overflow    ');
                                  putchr(pc, c); pc := pc+1
                                end;
                           7: begin skpspc;
                                   if ch <> '(' then errorl('ldc() expected           ');
                                   s := [ ];  getnxt;
                                   while ch<>')' do
                                   begin read(prd,s1); getnxt; s := s + [s1]
                                   end;
                                   cp := cp-setsize;
                                   alignd(setal, cp);
................................................................................
                     end;

           26, 95, 96, 97, 98, 99 (*chk*): begin
                         read(prd,lb,ub);
                         if op = 95 then q := lb
                         else
                         begin
                           cp := cp-intsize;
                           alignd(intal, cp);
                           if cp <= 0 then errorl('constant table overflow  ');
                           putint(cp, ub);
                           cp := cp-intsize;
                           alignd(intal, cp);
                           if cp <= 0 then errorl('constant table overflow  ');
                           putint(cp, lb); q := cp
                         end;
                         storeop; storeq
                       end;

................................................................................
                           end
                         until c = '''';
                         { place in storage }
                         cp := cp-l;
                         if cp <= 0 then errorl('constant table overflow  ');
                         q := cp;
                         for x := 1 to l do putchr(q+x-1, str[x]);
                         { this should have worked, the for loop is faulty
                           because the calculation for end is done after the i
                           set
                         for i := 0 to i-1 do putchr(q+i, str[i+1]);
                         }
                         storeop; storeq
                       end;

................................................................................
          22, 167, 168, 169, 170, 171,

          59, 133, 134, 135, 136, (*ord*)

          6, 80, 81, 82, 83, 84, (*sto*)

          { eof,adi,adr,sbi,sbr,sgs,flt,flo,trc,ngi,ngr,sqi,sqr,abi,abr,not,and,
            ior,dif,int,uni,inn,mod,odd,mpi,mpr,dvi,dvr,stp,chr,rnd,rgs,fbv,
            fvb }
          27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,
          48,49,50,51,52,53,54,58,60,62,110,111,
          115, 116: storeop;

                      (*ujc must have same length as ujp, so we output a dummy
                        q argument*)
................................................................................
   if dodmpsto then begin { dump storage overview }

      writeln;
      writeln('Storage areas occupied');
      writeln;
      write('Program     '); wrthex(0, maxdigh); write('-'); wrthex(pctop-1, maxdigh);
      writeln(' (',pctop:maxdigd,')');
      write('Stack/Heap  '); wrthex(pctop, maxdigh); write('-'); wrthex(cp-1, maxdigh);
      writeln(' (',cp-pctop+1:maxdigd,')');
      write('Constants   '); wrthex(cp, maxdigh); write('-'); wrthex(maxstr, maxdigh);
      writeln(' (',maxstr-(cp):maxdigd,')');
      writeln

   end;
   if dodmpins then dmpins; { Debug: dump instructions from store }
   if dodmplab then dmplabs { Debug: dump label definitions }

................................................................................
      writeln;
      write('pc = '); wrthex(pc-1, maxdigh);
      write(' op = ',op:3);
      write(' sp = '); wrthex(sp, maxdigh);
      write(' mp = '); wrthex(mp, maxdigh);
      write(' np = '); wrthex(np, maxdigh);
      write(' cp = '); wrthex(cp, maxdigh);
      writeln;
      write('------------------------------------------------------------');
      writeln('-------------');

      writeln;
      writeln('Stack');
      writeln;
      s := sp; i := 0;
................................................................................
   if store[fa] = 0 then begin { no file }
     if fa = pctop+inputoff then ff := inputfn
     else if fa = pctop+outputoff then ff := outputfn
     else if fa = pctop+prdoff then ff := prdfn
     else if fa = pctop+prroff then ff := prrfn
     else begin
       i := 5; { start search after the header files }
       ff := 0;
       while i <= maxfil do begin
         if filstate[i] = fclosed then begin ff := i; i := maxfil end;
         i := i+1
       end;
       if ff = 0 then errori('To many files            ');
     end;
     store[fa] := ff
   end
end;

................................................................................
begin
   writeln;
   writeln('Heap space breakdown');
   writeln;
   ad := np; { index the bottom of heap }
   while ad < cp do begin
      l := getadr(ad); { get next block length }
      write('addr: '); wrthex(ad, maxdigh); write(': ', abs(l):6, ': ');
      if l >= 0 then writeln('free') else writeln('alloc');
      ad := ad+abs(l)
   end
end;

{ find free block using length }

................................................................................
     l := getadr(blk); { get length }
     if l >= len+adrsize then begin b := blk; blk := cp end { found }
     else blk := blk+abs(l) { go next block }
  end;
  if b > 0 then begin { block was found }
     putadr(b, -(len+adrsize)); { allocate block }
     blk := b+adrsize; { set base address }
     if l > len+adrsize+adrsize+resspc then begin
        { If there is enough room for the block, header, and another header,
          then a reserve factor if desired. }
        b := b+len+adrsize; { go to top of allocated block }
        putadr(b, l-(len+adrsize)) { set length of stub space }
     end
  end else blk := 0 { set no block found }
end;
................................................................................

procedure cscspc;
var done: boolean;
    ad, ad1, l, l1: address;
begin
   { first, colapse all free blocks at the heap bottom }
   done := false;
   while not done and (np < cp) do begin
      l := getadr(np); { get header length }
      if l >= 0 then np := np+getadr(np) { free, skip block }
      else done := true { end }
   end;
   { now, walk up and collapse adjacent free blocks }
   ad := np; { index bottom }
   while ad < cp do begin
      l := getadr(ad); { get header length }
      if l >= 0 then begin { free }
         ad1 := ad+l; { index next block }
         if ad1 < cp then begin { not against end }
            l1 := getadr(ad1); { get length next }
            if l1 >=0 then
               putadr(ad, l+l1) { both blocks are free, combine the blocks }
            else ad := ad+l+abs(l1) { skip both blocks }
         end else ad := ad+l+abs(l1) { skip both blocks }
      end else ad := ad+abs(l) { skip this block }
   end
end;

................................................................................
     alignd(heapal, ad); { align to arena }
     len := len+(ad1-ad); { adjust length upwards for alignment }
     if ad <= ep then errori('store overflow           ');
     np:= ad;
     putadr(ad, -(len+adrsize)); { allocate block }
     blk := ad+adrsize { index start of block }
  end
end;

{ dispose of space in heap }

procedure dspspc(len, blk: address);
var ad: address;
begin
   len := len; { shut up compiler check }
................................................................................

   procedure putfile(var f: text; var ad: address);
   begin f^:= getchr(ad+fileidsize); put(f)
   end;(*putfile*)

begin (*callsp*)
      if q > maxsp then errori('invalid std proc/func    ');

      { trace routine executions }
      if dotrcrot then writeln(pc:6, '/', sp:6, '-> ', q:2);

      case q of
           0 (*get*): begin popadr(ad); valfil(ad); fn := store[ad];
                           if fn <= prrfn then case fn of
                              inputfn: getfile(input);
                              outputfn: errori('get on output file       ');
                              prdfn: getfile(prd);
                              prrfn: errori('get on prr file          ')
................................................................................
                              prrfn: writeln(prr)
                           end else begin
                                if filstate[fn] <> fwrite then
                                   errori('File not in write mode   ');
                                writeln(filtable[fn])
                           end
                      end;
           6 (*wrs*): begin popint(l); popint(w); popadr(ad1);
                           popadr(ad); pshadr(ad); valfil(ad); fn := store[ad];
                           if fn <= prrfn then case fn of
                              inputfn: errori('write on input file      ');
                              outputfn: writestr(output, ad1, w, l);
                              prdfn: errori('write on prd file        ');
                              prrfn: writestr(prr, ad1, w, l)
                           end else begin
................................................................................
                           if fn <= prrfn then case fn of
                                 inputfn: line:= eoln(input);
                                 outputfn: errori('eoln output file         ');
                                 prdfn: line:=eoln(prd);
                                 prrfn: errori('eoln on prr file         ')
                              end
                           else begin
                                if filstate[fn] <> fread then
                                   errori('File not in read mode    ');
                                line:=eoln(filtable[fn])
                           end;
                           pshint(ord(line))
                      end;
           8 (*wri*): begin popint(w); popint(i); popadr(ad); pshadr(ad);
                            valfil(ad); fn := store[ad];
                           if fn <= prrfn then case fn of
                                 inputfn: errori('write on input file      ');
                                 outputfn: write(output, i:w);
                                 prdfn: errori('write on prd file        ');
                                 prrfn: write(prr, i:w)
                              end
                           else begin
                                if filstate[fn] <> fwrite then
                                   errori('File not in write mode   ');
                                write(filtable[fn], i:w)
                           end
                      end;
           9 (*wrr*): begin popint(w); poprel(r); popadr(ad); pshadr(ad);
                            valfil(ad); fn := store[ad];
                           if fn <= prrfn then case fn of
                                 inputfn: errori('write on input file      ');
                                 outputfn: write(output, r: w);
                                 prdfn: errori('write on prd file        ');
                                 prrfn: write(prr, r:w)
                              end
                           else begin
                                if filstate[fn] <> fwrite then
                                   errori('File not in write mode   ');
                                write(filtable[fn], r:w)
                           end;
                      end;
           10(*wrc*): begin popint(w); popint(i); c := chr(i); popadr(ad);
                            pshadr(ad); valfil(ad); fn := store[ad];
                           if fn <= prrfn then case fn of
                                 inputfn: errori('write on input file      ');
                                 outputfn: write(output, c:w);
                                 prdfn: errori('write on prd file        ');
                                 prrfn: write(prr, c:w)
                              end
                           else begin
                                if filstate[fn] <> fwrite then
                                   errori('File not in write mode   ');
                                write(filtable[fn], c:w)
                           end
                      end;
           11(*rdi*): begin popadr(ad1); popadr(ad); pshadr(ad); valfil(ad);
                            fn := store[ad];
                           if fn <= prrfn then case fn of
                                 inputfn: begin readi(input, i); putint(ad1, i) end;
                                 outputfn: errori('read on output file      ');
                                 prdfn: begin readi(prd, i); putint(ad1, i) end;
                                 prrfn: errori('read on prr file         ')
                              end
                           else begin
                                if filstate[fn] <> fread then
                                   errori('File not in read mode    ');
                                readi(filtable[fn], i);
                                putint(ad1, i)
                           end
                      end;
           12(*rdr*): begin popadr(ad1); popadr(ad); pshadr(ad); valfil(ad);
                            fn := store[ad];
                           if fn <= prrfn then case fn of
                                 inputfn: begin readr(input, r); putrel(ad1, r) end;
                                 outputfn: errori('read on output file      ');
                                 prdfn: begin readr(prd, r); putrel(ad1, r) end;
                                 prrfn: errori('read on prr file         ')
                              end
................................................................................
                           else begin
                                if filstate[fn] <> fread then
                                   errori('File not in read mode    ');
                                readr(filtable[fn], r);
                                putrel(ad1, r)
                           end
                      end;
           13(*rdc*): begin popadr(ad1); popadr(ad); pshadr(ad); valfil(ad);
                            fn := store[ad];
                           if fn <= prrfn then case fn of
                                 inputfn: begin readc(input, c); putchr(ad1, c) end;
                                 outputfn: errori('read on output file      ');
                                 prdfn: begin readc(prd, c); putchr(ad1, c) end;
                                 prrfn: errori('read on prr file         ')
                              end
................................................................................
                      end;
           22(*rsf*): begin popadr(ad); valfil(ad); fn := store[ad];
                           if fn <= prrfn then case fn of
                                inputfn: errori('reset on input file      ');
                                outputfn: errori('reset on output file     ');
                                prdfn: reset(prd);
                                prrfn: errori('reset on prr file        ')
                              end
                           else begin
                                filstate[fn] := fread;
                                reset(filtable[fn]);
                           end
                      end;
           23(*rwf*): begin popadr(ad); valfil(ad); fn := store[ad];
                           if fn <= prrfn then case fn of
                                inputfn: errori('rewrite on input file    ');
                                outputfn: errori('rewrite on output file   ');
                                prdfn: errori('rewrite on prd file      ');
                                prrfn: rewrite(prr)
                              end
                           else begin
                                filstate[fn] := fwrite;
                                rewrite(filtable[fn]);
                           end
                      end;
           24(*wrb*): begin popint(w); popint(i); b := i <> 0; popadr(ad);
                            pshadr(ad); valfil(ad); fn := store[ad];
                           if fn <= prrfn then case fn of
                                 inputfn: errori('write on input file      ');
                                 outputfn: write(output, b:w);
                                 prdfn: errori('write on prd file        ');
                                 prrfn: write(prr, b:w)
                              end
                           else begin
                                if filstate[fn] <> fwrite then
                                   errori('File not in write mode   ');
                                write(filtable[fn], b:w)
                           end
                      end;
           25(*wrf*): begin popint(f); popint(w); poprel(r); popadr(ad); pshadr(ad);
                            valfil(ad); fn := store[ad];
                           if fn <= prrfn then case fn of
                                 inputfn: errori('write on input file      ');
                                 outputfn: write(output, r:w:f);
                                 prdfn: errori('write on prd file        ');
                                 prrfn: write(prr, r:w:f)
                              end
                           else begin
                                if filstate[fn] <> fwrite then
                                   errori('File not in write mode   ');
                                write(filtable[fn], r:w:f)
                           end
                      end;
           26(*dsp*): begin
                           popadr(ad1); popadr(ad); dspspc(ad1, getadr(ad))
                      end;
           27(*wbf*): begin popint(l); popadr(ad1); popadr(ad);
                           valfilwm(ad); fn := store[ad];
................................................................................
                      end;
           28(*wbi*): begin popint(i); popadr(ad); pshadr(ad); pshint(i);
                            valfilwm(ad); fn := store[ad];
                            for i := 1 to intsize do
                               write(bfiltable[fn], store[sp-intsize+i-1]);
                            popint(i)
                      end;
           29(*wbr*): begin poprel(r); popadr(ad); pshadr(ad); pshrel(r);
                            valfilwm(ad); fn := store[ad];
                            for i := 1 to realsize do
                               write(bfiltable[fn], store[sp-realsize+i-1]);
                            poprel(r)
                      end;
           30(*wbc*): begin popint(i); c := chr(i); popadr(ad); pshadr(ad); pshint(i);
                            valfilwm(ad); fn := store[ad];
                            for i := 1 to charsize do
                               write(bfiltable[fn], store[sp-intsize+i-1]);
                            popint(i)
                      end;
           31(*wbb*): begin popint(i); popadr(ad); pshadr(ad); pshint(i);
                            valfilwm(ad); fn := store[ad];
                            for i := 1 to boolsize do
                               write(bfiltable[fn], store[sp-intsize+i-1]);
                            popint(i)
                      end;
           32(*rbf*): begin popint(l); popadr(ad1); popadr(ad); pshadr(ad);
                            valfilrm(ad); fn := store[ad];
................................................................................
    { fetch instruction from byte store }
    pcs := pc; { save starting pc }
    getop;

    (*execute*)

    { trace executed instructions }
    if dotrcins then begin

       wrthex(pcs, maxdigh);
       write('/');
       wrthex(sp, maxdigh);
       lstins(pcs);
       writeln

................................................................................
          68 (*ldob*): begin getq; pshint(ord(getbol(pctop+q))) end;
          69 (*ldoc*): begin getq; pshint(ord(getchr(pctop+q))) end;

          2  (*stri*): begin getp; getq; popint(i); putint(base(p)+q, i) end;
          70 (*stra*): begin getp; getq; popadr(ad); putadr(base(p)+q, ad) end;
          71 (*strr*): begin getp; getq; poprel(r1); putrel(base(p)+q, r1) end;
          72 (*strs*): begin getp; getq; popset(s1); putset(base(p)+q, s1) end;
          73 (*strb*): begin getp; getq; popint(i1); b1 := i1 <> 0;
                             putbol(base(p)+q, b1) end;
          74 (*strc*): begin getp; getq; popint(i1); c1 := chr(i1);
                             putchr(base(p)+q, c1) end;

          3  (*sroi*): begin getq; popint(i); putint(pctop+q, i); end;
          75 (*sroa*): begin getq; popadr(ad); putadr(pctop+q, ad); end;
          76 (*sror*): begin getq; poprel(r1); putrel(pctop+q, r1); end;
................................................................................
          4 (*lda*): begin getp; getq; pshadr(base(p)+q) end;
          5 (*lao*): begin getq; pshadr(pctop+q) end;

          6  (*stoi*): begin popint(i); popadr(ad); putint(ad, i) end;
          80 (*stoa*): begin popadr(ad1); popadr(ad); putadr(ad, ad1) end;
          81 (*stor*): begin poprel(r1); popadr(ad); putrel(ad, r1) end;
          82 (*stos*): begin popset(s1); popadr(ad); putset(ad, s1) end;
          83 (*stob*): begin popint(i1); b1 := i1 <> 0; popadr(ad);
                             putbol(ad, b1) end;
          84 (*stoc*): begin popint(i1); c1 := chr(i1); popadr(ad);
                             putchr(ad, c1) end;

          127 (*ldcc*): begin pshint(ord(getchr(pc))); pc := pc+1 end;
          126 (*ldcb*): begin pshint(ord(getbol(pc))); pc := pc+1 end;
          123 (*ldci*): begin i := getint(pc); pc := pc+intsize; pshint(i) end;
          125 (*ldcn*): pshadr(nilval) (* load nil *) ;
          124 (*ldcr*): begin getq; pshrel(getrel(q)) end;
................................................................................
          170 { less }: errori('set inclusion            ');
          172 { lesm }: begin getq; compare; pshint(ord(not b and (store[a1+i] < store[a2+i]))) end;

          23 (*ujp*): begin getq; pc := q end;
          24 (*fjp*): begin getq; popint(i); if i = 0 then pc := q end;
          25 (*xjp*): begin getq; popint(i1); pc := i1*ujplen+q end;

          95 (*chka*): begin getq; popadr(a1); pshadr(a1);
                             {     0 = assign pointer including nil
                               Not 0 = assign pointer from heap address }
                             if a1 = 0 then
                                { if zero, but not nil, it's never been assigned }
                                errori('uninitialized pointer    ')
                             else if (q <> 0) and (a1 = nilval) then
                                { q <> 0 means deref, and it was nil
                                  (which is not zero) }
                                errori('Dereference of nil ptr   ')
                             else if ((a1 < np) or (a1 >= cp)) and
                                     (a1 <> nilval) then
                                { outside heap space (which could have
                                  contracted!) }
                                errori('bad pointer value        ')
                             else if dochkrpt and (a1 <> nilval) then begin
                                { perform use of freed space check }
                                if isfree(a1) then
                                   { attempt to dereference or assign a freed
                                     block }
                                   errori('Ptr used after dispose op')
                             end
                       end;
          96 (*chkr*),
          97 (*chks*): errori('Instruction error        ');
          98 (*chkb*),
          99 (*chkc*),
          26 (*chki*): begin getq; popint(i1); pshint(i1);
                        if (i1 < getint(q)) or (i1 > getint(q+intsize)) then
                        errori('value out of range       ')
                      end;

          27 (*eof*): begin popadr(ad); valfil(ad); fn := store[ad];
                            if fn <= prrfn then case fn of
                               inputfn: pshint(ord(eof(input)));
                               prdfn: pshint(ord(eof(prd)));
                               outputfn,
                               prrfn: errori('eof test on output file  ')
                            end else begin
                               if filstate[fn] = fwrite then pshint(ord(true))
                               else if filstate[fn] = fread then
                                  pshint(ord(eof(filtable[fn]) and not filbuff[fn]))
                               else errori('file is not open         ')
                            end
                      end;

          28 (*adi*): begin popint(i2); popint(i1); pshint(i1+i2) end;
          29 (*adr*): begin poprel(r2); poprel(r1); pshrel(r1+r2) end;
................................................................................
          36 (*ngi*): begin popint(i1); pshint(-i1) end;
          37 (*ngr*): begin poprel(r1); pshrel(-r1) end;
          38 (*sqi*): begin popint(i1); pshint(sqr(i1)) end;
          39 (*sqr*): begin poprel(r1); pshrel(sqr(r1)) end;
          40 (*abi*): begin popint(i1); pshint(abs(i1)) end;
          41 (*abr*): begin poprel(r1); pshrel(abs(r1)) end;
          42 (*not*): begin popint(i1); b1 := i1 <> 0; pshint(ord(not b1)) end;
          43 (*and*): begin popint(i2); b2 := i2 <> 0;
                            popint(i1); b1 := i1 <> 0;
                            pshint(ord(b1 and b2)) end;
          44 (*ior*): begin popint(i2); b2 := i2 <> 0;
                            popint(i1); b1 := i1 <> 0;
                            pshint(ord(b1 or b2)) end;
          45 (*dif*): begin popset(s2); popset(s1); pshset(s1-s2) end;
          46 (*int*): begin popset(s2); popset(s1); pshset(s1*s2) end;
          47 (*uni*): begin popset(s2); popset(s1); pshset(s1+s2) end;
          48 (*inn*): begin popset(s1); popint(i1); pshint(ord(i1 in s1)) end;
          49 (*mod*): begin popint(i2); popint(i1); pshint(i1 mod i2) end;
          50 (*odd*): begin popint(i1); pshint(ord(odd(i1))) end;
          51 (*mpi*): begin popint(i2); popint(i1); pshint(i1*i2) end;
          52 (*mpr*): begin poprel(r2); poprel(r1); pshrel(r1*r2) end;
          53 (*dvi*): begin popint(i2); popint(i1);
                            if i2 = 0 then errori('Zero divide              ');
                            pshint(i1 div i2) end;
          54 (*dvr*): begin poprel(r2); poprel(r1);
                            if r2 = 0.0 then errori('Zero divide              ');
                            pshrel(r1/r2) end;
          55 (*mov*): begin getq; popint(i2); popint(i1);
                       for i3 := 0 to q-1 do store[i1+i3] := store[i2+i3]
                       (* q is a number of storage units *)
                      end;
          56 (*lca*): begin getq; pshadr(q) end;
................................................................................
                      popadr(ad); pshadr(ad); valfilrm(ad); fn := store[ad];
                      { eof is file eof, and buffer not full }
                      pshint(ord(eof(bfiltable[fn]) and not filbuff[fn]))
                     end;
          116 (*fvb*): begin popint(i); popadr(ad); pshadr(ad); valfil(ad);
                      fn := store[ad];
                      { load buffer only if in read mode, and buffer is empty }
                      if (filstate[fn] = fread) and not filbuff[fn] then begin
                        for j := 1 to i do
                          read(bfiltable[fn], store[ad+fileidsize+j-1]);
                        filbuff[fn] := true
                      end
                    end;
          117 (*dmp*): begin getq; sp := sp-q end; { remove top of stack }

................................................................................
          119 (*tjp*): begin getq; popint(i); if i <> 0 then pc := q end;

          120 (*lip*): begin getp; getq; ad := base(p) + q;
                        i := getadr(ad); a1 := getadr(ad+1*ptrsize);
                        pshadr(i); pshadr(a1)
                      end;

          174 (*mrkl*): begin getq; srclin := q;
                              if dotrcsrc then
                                writeln('Source line executed: ', q:1)
                        end;

          { illegal instructions }
          8,   121, 122, 175, 176, 177, 178,
          180, 181, 182, 183, 184, 185, 186, 187, 188, 189,
          190, 191, 192, 193, 194, 195, 196, 197, 198, 199,
          200, 201, 202, 203, 204, 205, 206, 207, 208, 209,
          210, 211, 212, 213, 214, 215, 216, 217, 218, 219,
          220, 221, 222, 223, 224, 225, 226, 227, 228, 229,
          230, 231, 232, 233, 234, 235, 236, 237, 238, 239,
          240, 241, 242, 243, 244, 245, 246, 247, 248, 249,
          250, 251, 252, 253, 254,
          255: errori('illegal instruction      ');

    end
  end; (*while interpreting*)

  { perform heap dump if requested }
  if dodmpspc then repspc;