home *** CD-ROM | disk | FTP | other *** search
/ Otherware / Otherware_1_SB_Development.iso / amiga / programm / language / bcpl4ami.lzh / bcpl / bpl / icint.bpl < prev    next >
Encoding:
BCPL source  |  1988-03-25  |  10.4 KB  |  366 lines
  1. //     This program is an ASCII INTCODE assembler and interpreter
  2. // for a 16 bit EBCDIC machine,  hence the need for the ASCII and
  3. // EBCDIC tables near the end.  It has been tested on the IBM 370
  4. // (a 32 bit EBCDIC machine).
  5.  
  6. GET "LIBHDR"
  7.  
  8. GLOBAL $(
  9. SYSPRINT:100; SOURCE:101
  10. ETOA:102; ATOE:103
  11. $)
  12.  
  13. MANIFEST $(
  14. FSHIFT=13
  15. IBIT=#10000; PBIT=#4000; GBIT=#2000; DBIT=#1000
  16. ABITS=#777
  17. WORDSIZE=16; BYTESIZE=8
  18. LIG1=#012001
  19. K2  =#140002
  20. X22 =#160026
  21. $)
  22.  
  23. GLOBAL $(
  24. G:110; P:111; CH:112; CYCLECOUNT:113
  25. LABV:120; CP:121; A:122; B:123; C:124; D:125; W:126  $)
  26.  
  27.  
  28.  
  29. LET ASSEMBLE() BE
  30. $(1   LET V = VEC 500
  31.       LET F = 0
  32.       LABV := V
  33.  
  34. CLEAR:FOR I = 0 TO 500 DO LABV]I := 0
  35.       CP := 0
  36.  
  37. NEXT: RCH()
  38. SW:   SWITCHON CH INTO
  39.  
  40. $(S   DEFAULT: IF CH=ENDSTREAMCH RETURN
  41.                WRITEF("*NBAD CH %C AT P = %N*N", CH, P)
  42.                GOTO NEXT
  43.  
  44.       CASE '0':CASE '1':CASE '2':CASE '3':CASE '4':
  45.       CASE '5':CASE '6':CASE '7':CASE '8':CASE '9':
  46.                SETLAB(RDN())
  47.                CP := 0
  48.                GOTO SW
  49.  
  50.       CASE '$':CASE '*S':CASE '*N': GOTO NEXT
  51.  
  52.       CASE 'L': F := 0; ENDCASE
  53.       CASE 'S': F := 1; ENDCASE
  54.       CASE 'A': F := 2; ENDCASE
  55.       CASE 'J': F := 3; ENDCASE
  56.       CASE 'T': F := 4; ENDCASE
  57.       CASE 'F': F := 5; ENDCASE
  58.       CASE 'K': F := 6; ENDCASE
  59.       CASE 'X': F := 7; ENDCASE
  60.  
  61.       CASE 'C': RCH(); STC(RDN()); GOTO SW
  62.  
  63.       CASE 'D': RCH()
  64.                 TEST CH='L'
  65.                   THEN $( RCH()
  66.                           STW(0)
  67.                           LABREF(RDN(), P-1)  $)
  68.                   OR STW(RDN())
  69.                 GOTO SW
  70.  
  71.       CASE 'G': RCH()
  72.                 A := RDN() + G
  73.                 TEST CH='L' THEN RCH()
  74.                       OR WRITEF("*NBAD CODE AT P = %N*N", P)
  75.                 ]A := 0
  76.                 LABREF(RDN(), A)
  77.                 GOTO SW
  78.  
  79.       CASE 'Z': FOR I = 0 TO 500 DO
  80.                    IF LABV]I>0 DO WRITEF("L%N UNSET*N", I)
  81.                 GOTO CLEAR  $)S
  82.  
  83.  
  84.       W := F<<FSHIFT
  85.       RCH()
  86.       IF CH='I' DO $( W := W+IBIT; RCH() $)
  87.       IF CH='P' DO $( W := W+PBIT; RCH() $)
  88.       IF CH='G' DO $( W := W+GBIT; RCH() $)
  89.  
  90.       TEST CH='L'
  91.  
  92.         THEN $( RCH()
  93.                 STW(W+DBIT)
  94.                 STW(0)
  95.                 LABREF(RDN(), P-1)  $)
  96.  
  97.         OR   $( LET A = RDN()
  98.                 TEST (A&ABITS)=A
  99.                   THEN STW(W+A)
  100.                   OR $( STW(W+DBIT); STW(A)  $)  $)
  101.  
  102.       GOTO SW   $)1
  103.  
  104. AND STW(W) BE $( ]P := W
  105.                  P, CP := P+1, 0  $)
  106.  
  107. AND STC(C) BE $( IF CP=0 DO $( STW(0); CP := WORDSIZE  $)
  108.                  CP := CP - BYTESIZE
  109.                  ](P-1) := ](P-1) + (C<<CP)  $)
  110.  
  111. AND RCH() BE $(1 CH := RDCH()
  112.                  UNLESS CH='/' RETURN
  113.                  UNTIL CH='*N' DO CH := RDCH()  $)1 REPEAT
  114.  
  115. AND RDN() = VALOF
  116.     $( LET A, B = 0, FALSE
  117.        IF CH='-' DO $( B := TRUE; RCH()  $)
  118.        WHILE '0'<=CH<='9' DO $( A := 10*A + CH - '0'; RCH()  $)
  119.        IF B DO A := -A
  120.        RESULTIS A  $)
  121.  
  122. AND SETLAB(N) BE
  123.      $( LET K = LABV]N
  124.         IF K<0 DO WRITEF("L%N ALREADY SET TO %N AT P = %N*N",N,-K,P)
  125.         WHILE K>0 DO $( LET N = ]K
  126.                         ]K := P
  127.                         K := N  $)
  128.         LABV]N := -P  $)
  129.  
  130.  
  131. AND LABREF(N, A) BE
  132.     $( LET K = LABV]N
  133.        TEST K<0 THEN K := -K OR LABV]N := A
  134.        ]A := ]A + K  $)
  135.  
  136.  
  137. AND INTERPRET() = VALOF
  138. $(1
  139.  
  140. FETCH: CYCLECOUNT := CYCLECOUNT + 1
  141.        W := ]C
  142.        C := C + 1
  143.  
  144.        TEST (W&DBIT)=0
  145.          THEN D := W&ABITS
  146.          OR $( D := ]C; C := C+1  $)
  147.  
  148.        IF (W & PBIT) NE 0 DO D := D + P
  149.        IF (W & GBIT) NE 0 DO D := D + G
  150.        IF (W & IBIT) NE 0 DO D := ]D
  151.  
  152.        SWITCHON W>>FSHIFT INTO
  153.  
  154.    $(  ERROR:
  155.        DEFAULT: SELECTOUTPUT(SYSPRINT)
  156.                 WRITEF("*NINTCODE ERROR AT C = %N*N", C-1)
  157.                 RESULTIS -1
  158.  
  159.        CASE 0: B := A; A := D; GOTO FETCH
  160.  
  161.        CASE 1: ]D := A; GOTO FETCH
  162.  
  163.        CASE 2: A := A + D; GOTO FETCH
  164.  
  165.        CASE 3: C := D; GOTO FETCH
  166.  
  167.        CASE 4: A := NOT A
  168.  
  169.        CASE 5: UNLESS A DO C := D; GOTO FETCH
  170.  
  171.        CASE 6: D := P + D
  172.                D]0, D]1 := P, C
  173.                P, C := D, A
  174.                GOTO FETCH
  175.  
  176.        CASE 7: SWITCHON D INTO
  177.  
  178.        $(  DEFAULT: GOTO ERROR
  179.  
  180.            CASE 1:  A := ]A; GOTO FETCH
  181.            CASE 2:  A := -A;     GOTO FETCH
  182.            CASE 3:  A := NOT A; GOTO FETCH
  183.            CASE 4:  C := P]1
  184.                     P := P]0
  185.                     GOTO FETCH
  186.            CASE 5:  A := B * A; GOTO FETCH
  187.            CASE 6:  A := B / A; GOTO FETCH
  188.            CASE 7:  A := B REM A; GOTO FETCH
  189.            CASE 8:  A := B + A; GOTO FETCH
  190.            CASE 9:  A := B - A; GOTO FETCH
  191.            CASE 10: A := B = A; GOTO FETCH
  192.            CASE 11: A := B NE A; GOTO FETCH
  193.            CASE 12: A := B < A; GOTO FETCH
  194.            CASE 13: A := B >= A; GOTO FETCH
  195.            CASE 14: A := B > A; GOTO FETCH
  196.            CASE 15: A := B <= A; GOTO FETCH
  197.            CASE 16: A := B << A; GOTO FETCH
  198.            CASE 17: A := B >> A; GOTO FETCH
  199.            CASE 18: A := B & A; GOTO FETCH
  200.            CASE 19: A := B LOGOR A; GOTO FETCH
  201.            CASE 20: A := B NEQV A; GOTO FETCH
  202.            CASE 21: A := B EQV A;  GOTO FETCH
  203.  
  204.            CASE 22: RESULTIS 0   // FINISH
  205.  
  206.            CASE 23: B, D := C]0, C]1   // SWITCHON
  207.                     UNTIL B=0 DO
  208.                         $( B, C := B-1, C+2
  209.                            IF A=C]0 DO
  210.                                   $( D := C]1
  211.                                      BREAK  $)  $)
  212.                      C := D
  213.                      GOTO FETCH
  214.  
  215. // CASES 24 UPWARDS ARE ONLY CALLED FROM THE FOLLOWING
  216. // HAND WRITTEN INTCODE LIBRARY - ICLIB:
  217.  
  218. //    11 LIP2 X24 X4 G11L11 /SELECTINPUT
  219. //    12 LIP2 X25 X4 G12L12 /SELECTOUTPUT
  220. //    13 X26 X4      G13L13 /RDCH
  221. //    14 LIP2 X27 X4 G14L14 /WRCH
  222. //    42 LIP2 X28 X4 G42L42 /FINDINPUT
  223. //    41 LIP2 X29 X4 G41L41 /FINDOUTPUT
  224. //    30 LIP2 X30 X4 G30L30 /STOP
  225. //    31 X31 X4 G31L31 /LEVEL
  226. //    32 LIP3 LIP2 X32 G32L32 /LONGJUMP
  227. //    46 X33 X4 G46L46 /ENDREAD
  228. //    47 X34 X4 G47L47 /ENDWRITE
  229. //    40 LIP3 LIP2 X35 G40L40 /APTOVEC
  230. //    85 LIP3 LIP2 X36 X4 G85L85 / GETBYTE
  231. //    86 LIP3 LIP2 X37 X4 G86L86 / PUTBYTE
  232. //    Z
  233.  
  234.            CASE 24: SELECTINPUT(A); GOTO FETCH
  235.            CASE 25: SELECTOUTPUT(A); GOTO FETCH
  236.            CASE 26: A := ETOA]RDCH(); GOTO FETCH
  237.            CASE 27: WRCH(ATOE]A); GOTO FETCH
  238.            CASE 28: A := FINDINPUT(STRING370(A)); GOTO FETCH
  239.            CASE 29: A := FINDOUTPUT(STRING370(A)); GOTO FETCH
  240.            CASE 30: RESULTIS A  // STOP(A)
  241.            CASE 31: A := P]0; GOTO FETCH  // USED IN LEVEL()
  242.            CASE 32: P, C := A, B;         // USED IN LONGJUMP(P,L)
  243.                     GOTO FETCH
  244.            CASE 33: ENDREAD(); GOTO FETCH
  245.            CASE 34: ENDWRITE(); GOTO FETCH
  246.            CASE 35: D := P+B+1        // USED IN APTOVEC(F, N)
  247.                     D]0, D]1, D]2, D]3 := P]0, P]1, P, B
  248.                     P, C := D, A
  249.                     GOTO FETCH
  250.            CASE 36: A := ICGETBYTE(A, B)  // GETBYTE(S, I)
  251.                     GOTO FETCH
  252.            CASE 37: ICPUTBYTE(A, B, P]4)  // PUTBYTE(S, I, CH)
  253.                     GOTO FETCH
  254.       $)  $)  $)1
  255.  
  256.  
  257. AND STRING370(S) = VALOF
  258.      $( LET T = TABLE 0,0,0,0,0,0,0,0
  259.  
  260.         PUTBYTE(T, 0, ICGETBYTE(S, 0))
  261.         FOR I = 1 TO ICGETBYTE(S,0) DO
  262.                   PUTBYTE(T,I,ATOE]ICGETBYTE(S,I))
  263.  
  264.         RESULTIS T  $)
  265.  
  266. AND ICGETBYTE(S, I) = VALOF
  267.      $( LET W = S](I/2)
  268.         IF (I&1)=0 DO W := W>>8
  269.         RESULTIS W&255  $)
  270.  
  271. AND ICPUTBYTE(S, I, CH) BE
  272.      $( LET P = @S](I/2)
  273.         LET W = ]P
  274.         TEST (I&1)=0 THEN ]P := Wÿ ▓/ CH<<8
  275.                      OR   ]P := W＀ ▓/ CH    $)
  276.  
  277. LET START(PARM) BE
  278. $(1
  279.  
  280. LET PROGVEC = VEC 20000
  281. LET GLOBVEC = VEC 400
  282.  
  283. G, P := GLOBVEC, PROGVEC
  284.  
  285. SYSPRINT := FINDOUTPUT("SYSPRINT")
  286. SELECTOUTPUT(SYSPRINT)
  287.  
  288. WRITES("INTCODE SYSTEM ENTERED*N")
  289.  
  290. SOURCE := FINDINPUT("INTIN")
  291. SELECTINPUT(SOURCE)
  292. ASSEMBLE()
  293. SOURCE := FINDINPUT("SYSIN")
  294. UNLESS SOURCE=0 DO SELECTINPUT(SOURCE)
  295.  
  296. WRITEF("*NPROGRAM SIZE = %N*N", P-PROGVEC)
  297.  
  298. ATOE := 1+TABLE -1,
  299.           0,  0,  0,  0,  0,  0,  0,  0,  // ASCII TO EBCDIC
  300.           0,  5, 21,  0, 12,  0,  0,  0,  // '*T' '*N' '*P'
  301.           0,  0,  0,  0,  0,  0,  0,  0,
  302.           0,  0,  0,  0,  0,  0,  0,  0,
  303.  
  304.          64, 90,127,123, 91,108, 80,125, // '*S' ] " # $ % & '
  305.          77, 93, 92, 78,107, 96, 75, 97, //   (  ) * + , - . /
  306.         240,241,242,243,244,245,246,247, //   0  1 2 3 4 5 6 7
  307.         248,249,122, 94, 76,126,110,111, //   8  9 : ; < = > ?
  308.         124,193,194,195,196,197,198,199, //   @  A B C D E F G
  309.         200,201,209,210,211,212,213,214, //   H  I J K L M N O
  310.         215,216,217,226,227,228,229,230, //   P  Q R S T U V W
  311.         231,232,233, 66, 98, 67,101,102, //   X  Y Z í ▓ ó ╡ ╢
  312.          64,129,130,131,132,133,134,135, //      a b c d e f g
  313.         136,137,145,146,147,148,149,150, //   h  i j k l m n o
  314.         151,152,153,162,163,164,165,166, //   p  q r s t u v w
  315.         167,168,169, 64, 79, 64, 95,255  //   x  y z   !   ^
  316.  
  317.  
  318. ETOA := 1+TABLE -1,
  319.       0,   0,   0,   0,   0, #11,   0,   0,
  320.       0,   0,   0, #13, #14, #15,   0,   0,
  321.       0,   0,   0,   0,   0, #12,   0,   0,
  322.       0,   0,   0,   0,   0,   0,   0,   0,
  323.       0,   0,   0,   0,   0, #12,   0,   0,
  324.       0,   0,   0,   0,   0,   0,   0,   0,
  325.       0,   0,   0,   0,   0,   0,   0,   0,
  326.       0,   0,   0,   0,   0,   0,   0,   0,
  327.     #40,   0,#133,#135,   0,   0,   0,   0,
  328.       0,   0,   0, #56, #74, #50, #53,#174,
  329.     #46,   0,   0,   0,   0,   0,   0,   0,
  330.       0,   0, #41, #44, #52, #51, #73,#176,
  331.     #55, #57,#134,   0,   0,#136,#137,   0,
  332.       0,   0,   0, #54, #45,#140, #76, #77,
  333.       0,   0,   0,   0,   0,   0,   0,   0,
  334.       0,   0, #72, #43,#100, #47, #75, #42,
  335.       0,#141,#142,#143,#144,#145,#146,#147,
  336.    #150,#151,   0,   0,   0,   0,   0,   0,
  337.       0,#152,#153,#154,#155,#156,#157,#160,
  338.    #161,#162,   0,   0,   0,   0,   0,   0,
  339.       0,   0,#163,#164,#165,#166,#167,#170,
  340.    #171,#172,   0,   0,   0,   0,   0,   0,
  341.       0,   0,   0,   0,   0,   0,   0,   0,
  342.       0,   0,   0,   0,   0,   0,   0,   0,
  343.       0,#101,#102,#103,#104,#105,#106,#107,
  344.    #110,#111,   0,   0,   0,   0,   0,   0,
  345.       0,#112,#113,#114,#115,#116,#117,#120,
  346.    #121,#122,   0,   0,   0,   0,   0,   0,
  347.       0,   0,#123,#124,#125,#126,#127,#130,
  348.    #131,#132,   0,   0,   0,   0,   0,   0,
  349.     #60, #61, #62, #63, #64, #65, #66, #67,
  350.     #70, #71,   0,   0,   0,   0,   0,   0
  351.  
  352.  
  353.  
  354. C := TABLE LIG1, K2, X22
  355.  
  356. CYCLECOUNT := 0
  357. A := INTERPRET()
  358.  
  359. SELECTOUTPUT(SYSPRINT)
  360. WRITEF("*N*NEXECUTION CYCLES = %N, CODE = %N*N", CYCLECOUNT, A)
  361. IF A<0 DO MAPSTORE()
  362. FINISH  $)1
  363.  
  364.  
  365.  
  366.