home *** CD-ROM | disk | FTP | other *** search
/ Oakland CPM Archive / oakcpm.iso / sigm / vol114 / pistol.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1984-04-29  |  39.5 KB  |  1,839 lines
  1. (*********************************************************)
  2. (*                             *)
  3. (* PISTOL-Portably Implemented Stack Oriented Language     *)
  4. (*            Version 2.0             *)
  5. (* (C) 1983 by    Ernest E. Bergmann             *)
  6. (*        Physics, Building #16             *)
  7. (*        Lehigh Univerisity             *)
  8. (*        Bethlehem, Pa. 18015             *)
  9. (*                             *)
  10. (* Permission is hereby granted for all reproduction and *)
  11. (* distribution of this material provided this notice is *)
  12. (* included.                         *)
  13. (*                             *)
  14. (*********************************************************)
  15.  
  16. PROGRAM PISTOL(INPUT:/);
  17. (*SEP 7, 1982: DOTDOT *)
  18. (* SEP 4:CRDMP,INIT,MININT *)
  19. (* AUG 30:FIX OF TTYI FOR LINE ORIENTATION *)
  20. (*$C- JULY 19.., 1982 -> VER2.0;USER->USR *)
  21. (* JULY 13: CHANGED MOVE,FENTER;DEFINED NEWLINE *)
  22. (* JULY 12: REMOVED SCRATCH -10..-8;DEFINED FNAME *)
  23. (* JULY 8: VFIND MADE PRIMITIVE;PREV -.>USR+W*6 *)
  24. (*JULY 5,82:FIND,VFIND REDEFINED*)
  25. (*JUNE 28,82: POP ADDED*)
  26. (*JUNE 17,82: KRNQ->PRMQ ; KERNEL?->PRIMITIVE? *)
  27.  
  28. (*DECEMBER 22, 1981 --FOR BEST PERFORMANCE IN PASCAL,
  29.     THIS PROGRAM SHOULD BE EDITED TO MAKE FULL USE
  30.     OF THE OPTIONS, USR=0,W=1,S=1,CSTEP=1,L=1,R=1
  31.     AND STRINGSMIN=-1 *)
  32.  
  33. LABEL 99;
  34. CONST
  35. VERSION=20;(*10* THE VERSION NUMBER,READABLE BY USER*)
  36. USR=0;(*DISPLACEMENT FOR USER'S RAM AREA; IT SHOULD
  37.     BE CHANGED TO SIMPLIFY ADDRESS CALCULATION IN
  38.     ASSEMBLY CODE IMPLEMENTATIONS*)
  39. W=1;(*RAM ADDRESS INCREMENT SIZE; TYPICALLY WOULD BE
  40.     2 OR 4 FOR 8-BIT MICROS AND OTHER BYTE ADDRESSABLE
  41.     MACHINES*)
  42. R=1;(*INCREMENT SIZE FOR RSTACK,HIDDEN FROM USER*)
  43. S=1;(*INCREMENT SIZE FOR (PARAMETER) STACK,HIDDEN*)
  44. STACKMIN=0;(*WHATEVER IS CONVENIENT,HIDDEN FROM USER*)
  45. MSTACKMIN=-3;(*STACKMIN-S*3*)
  46. PSTACKMAX=203;(*STACKMAX+S*3*)
  47. STACKMAX=200;(*STACKMIN+SSIZE*S*)
  48. LSTACKMIN=0;(*WHATEVER IS CONVENIENT,HIDDEN FROM USER*)
  49. L=1;(*LSTACK INCREMENT,HIDDEN FROM USER*)
  50. LSTACKMAX=30;(*LSTACKMIN+LSIZE*L*)
  51. CSTACKMIN=0;(*WHATEVER IS CONVENIENT*)
  52. CSTEP=1;(*CSTACK INCREMENT*)
  53. CSTACKMAX=30;(*CSTACKMIN+CSIZE*CSTEP*)
  54. NUMINSTR=73;
  55. RAMMIN=-21(*USR-W*21,OR LOWER,READABLE*);
  56. NEWLINE=10;(*ASCII TOKEN USED TO MARK LINE END,
  57.         USUALLY A CR OR A LF *)
  58. MAXORD=127;(*7 BIT FOR DEC-20,READABLE*)
  59. RAMMAX=8000;(*=RAMMIN+W*5000 AT LEAST,READABLE BY USER*)
  60. COMPBUF=7000;(*=RAMMAX-W*200,OR LOWER,READABLE BY USER*)
  61. SSIZE=200;(*READABLE BY USER*)
  62. RSIZE=30;(*READABLE BY USER*)
  63. RSTACKMIN=0;(*ARBITRARY,HIDDEN*)
  64. RSTACKMAX=30;(*RSTACKMIN+R*RSIZE*)
  65. LSIZE=30;(*READABLE BY USER*)
  66. CSIZE=30;(*READABLE BY USER*)
  67. (*VOCABULARY STACK IS LOCATED IN RAM*)
  68. VSIZE=8;(*VOCAB STACK,READABLE BY USER*)
  69. VBASE=41;
  70. STRINGSMIN=8000(*READABLE BY USER*);
  71. (*IF STRINGSMIN>RAMMAX,PROTECTION IS MORE COMPLETE*)
  72. SYNTAXBASE=8001(*STRINGSMIN+1*);
  73. STRINGSMAX=13500;(*STRINGSMIN+ 3500..5500 INTENDED FOR EDIT AREA *)
  74. MAXLINNO=300;(*MAX # OF LINES POSSIBLE IN EDIT BUFFER,
  75.         READABLE BY USER*)
  76. LINEBUF=11300;(*STRINGSMIN+3300,READABLE BY USER*)
  77. CHKLMT=20(*SIZE OF CHECK STACK,READABLE BY USER*);
  78. FALS=0; TRU=-1;
  79.  
  80. (* OPCODES WHOSE VALUES ARE NOT CRITICAL; THEY MUST BE
  81.    UNIQUE AND RECOGNIZEABLE BY PRIMQ, AND SEPERABLE
  82.    INTO PINT1 AND PINT2 *)
  83.     PSEMICOLON=0;
  84.     WSTORE=1;
  85.     TIMES=2;
  86.     PLUS=3;
  87.     SUBTRACT=4;
  88.     DIVMOD=5;
  89.     PIF=6;
  90.     WAT=7;
  91.     ABRT=8;
  92.     SP=9;
  93.     LOAD=10;
  94.     PELSE=11;
  95.     WRD=12;
  96.     RP=13;
  97.     DROPOP=14;
  98.     PUSER=15;
  99.     EXEC=16;
  100.     EXITOP=17;
  101.     LIT=18;
  102.     STRLIT=19;
  103.     RPOP=20;
  104.     SWP=21;
  105.     TYI=22;
  106.     TYO=23;
  107.     RPSH=24;
  108.     SEMICF=25;
  109.     RAT=26;
  110.     COMPME=27;
  111.     COMPHERE=28;
  112.     DOLLARC=29;
  113.     COLON=30;
  114.     SEMICOLON=31;
  115.     IFOP=32;
  116.     ELSEOP=33;
  117.     THENOP=34;
  118.     DOOP=35;
  119.     LOOPOP=36;
  120.     BEGINOP=37;
  121.     ENDOP=38;
  122.     REPET=39;
  123.     PERCENT=40;
  124.     PDOLLAR=41;
  125.     PCOLON=42;
  126.     CASAT=43;
  127.     PDOOP=44;
  128.     PPLOOP=45;
  129.     PLLOOP=46;
  130.     CAT=47;
  131.     CSTORE=48;
  132.     PLOOP=49;
  133.     DOTDOT=50;
  134.     SEMIDOL=51;
  135.     PRMQ=52;
  136.     CORDMP=53;
  137.     RESTOR=54;
  138.     SAT=55;
  139.     FINDOP=56;
  140.     LISTFIL=57;
  141.     VFINDOP=58;
  142.     LAT=59;
  143.     OFCAS=60;
  144.     CCOLON=61;
  145.     SEMICC=62;
  146.     NDCAS=63;
  147.     POFCAS=64;
  148.     PCCOL=65;
  149.     PSEMICC=66;
  150.     GTLIN=67;
  151.     WORD=68;
  152.     OPENR=69;
  153.     OPENW=70;
  154.     READL=71;
  155.     WRITL=72;
  156. (* END OF OPCODE DECLARATIONS *)
  157.  
  158.  
  159.  
  160.  
  161. TYPE DALFA = PACKED ARRAY[1..20] OF CHAR;
  162.  
  163. IMAGE=    RECORD
  164.     STRINGS:PACKED ARRAY[STRINGSMIN..STRINGSMAX] OF CHAR;
  165.     RAM:ARRAY[RAMMIN..RAMMAX] OF INTEGER;
  166.     END(*RECORD*);
  167.  
  168. IMFILE=FILE OF IMAGE;
  169.  
  170. VAR
  171. IMAGENAME,NAMEIN,NAMOUT,INFIL,LISTNAME,NULLNAME:DALFA;
  172. IP:INTEGER;(*INSTRUCTION POINTER*)
  173. INSTR:INTEGER;(*INSTRUCTION CURRENTLY EXECUTED BY INTERPRET*)
  174. SAVINSTR:INTEGER(*SAVES INSTR DURING TRACING*);
  175. SAVLEVEL:INTEGER(*SAVES LEVEL DURING TRACING*);
  176. TEMP: INTEGER;
  177. EDIN,EDOUT,LDFIL,LIST,OUTPUT:TEXT;
  178. (*SAVEFILE:IMFILE; IN CRDMP,RSTOR ROUTINES *)
  179. READV,WRITV:INTEGER;(*READ_PROTECT,WRITE_PROTECT*)
  180. NOPEN,FEOF,UNDFLO,OVFLO,SYNT,ID,REDEF,ADDR,VAL,I,DIVBY0:INTEGER;
  181. C:CHAR;
  182. KEYCURS,KEYLEN:INTEGER;
  183. KEYSTRING:PACKED ARRAY[0..MAXORD] OF CHAR;
  184.  
  185. (* CONSTANTS:
  186.     RAM[..RAMMIN-W]=FUTURE CONSTANTS
  187.     RAM[USR-W*21]=MININT
  188.     RAM[USR-W*20]=MAXLINNO
  189.     RAM[USR-W*19]=CHKLMT
  190.     RAM[USR-W*18]=RAMMIN
  191.     RAM[USR-W*17]=STRINGSMIN
  192.     RAM[USR-W*16]=STRINGSMAX
  193.     RAM[USR-W*15]=VBASE
  194.     RAM[USR-W*14]=VSIZE
  195.     RAM[USR-W*13]=CSIZE
  196.     RAM[USR-W*12]=LSIZE
  197.     RAM[USR-W*11]=RSIZE
  198.     RAM[USR-W*10]=SSIZE
  199.     RAM[USR-W*9]=LINEBUF
  200.     RAM[USR-W*8]=COMPBUF
  201.     RAM[USR-W*7]=RAMMAX
  202.     RAM[USR-W*6]=MAXORD
  203.     RAM[USR-W*5]=MAXINT
  204.     RAM[USR-W*4]=VERSION TIMES TEN
  205.     RAM[USR-W*3]=NEWLINE CHAR
  206.     RAM[USR-W*2]=READ PROTECTION BOOLEAN
  207.     RAM[USR-W*1]=WRITE PROTECTION BOOLEAN
  208.    VARIABLES:
  209.     RAM[USR+W*0]=RADIX
  210.     RAM[USR+W*1]=.C
  211.     RAM[USR+W*2]=.D
  212.     RAM[USR+W*3]=CURRENT END OF STRINGS
  213.     RAM[USR+W*4]=OLD END OF STRINGS
  214.     RAM[USR+W*5]=CURRENT
  215.     RAM[USR+W*6]=PREV(VFIND)
  216.     RAM[USR+W*7]=INPUT FILE
  217.     RAM[USR+W*8]=LIST OUT BOOLEAN
  218.     RAM[USR+W*9]=ECHO OUT BOOLEAN
  219.     RAM[USR+W*10]=CONSOLE OUT BOOLEAN
  220.     RAM[USR+W*11]=NEXTCHAR POINTER
  221.     RAM[USR+W*12]=LINELENGTH
  222.     RAM[USR+W*13]=RAISE BOOLEAN LC->UC
  223.     RAM[USR+W*14]=HEAD OF TOKEN IN LINE
  224.     RAM[USR+W*15]=TRACE BOOLEAN AND LEVEL
  225.     RAM[USR+W*16]=COMPILE_END PATCH
  226.     RAM[USR+W*17]=TERMINAL PAGE LENGTH
  227.     RAM[USR+W*18]=#LINE OUTPUT TO CONSOLE
  228.     RAM[USR+W*19]=TERMINAL WIDTH
  229.     RAM[USR+W*20]=COLUMN
  230.     RAM[USR+W*21]=ENDCASE PATCH ADDRESS
  231.     RAM[USR+W*22]=TRACE PATCH ADDRESS
  232.     RAM[USR+W*23]=TABSIZE
  233.     RAM[USR+W*24]=#GETLINE PATCH ADDRESS
  234.     RAM[USR+W*25]=FILE STATUS FOR LDFIL
  235.     RAM[USR+W*26]=FILE STATUS FOR EDIN
  236.     RAM[USR+W*27]=FILE STATUS FOR EDOUT
  237.     RAM[USR+W*28]=^ VSTACK
  238.     RAM[USR+W*29]=^PISTOL<
  239.     RAM[USR+W*30]=NIL,TERMINATES VLIST
  240.     RAM[USR+W*31]=SESSION DONE BOOLEAN
  241.     RAM[USR+W*32]=PROMPT PATCH ADDRESS
  242.     RAM[USR+W*33]=CONVERSION PATCH
  243.     RAM[USR+W*34]=ABORT PATCH
  244.     RAM[USR+W*(35..VBASE-1)]=FUTURE VARIABLES EXPANSION
  245.     RAM[VBASE..VBASE+W*VSIZE]=VSTACK
  246.     RAM[...]=INFO SAVED DURING AN ABORT, SUCH AS
  247.     OFFENDING INSTRUCTION,LOCATION,RETURN STACK
  248. *)
  249.  
  250. MEMORY:IMAGE;
  251. STKPTR:INTEGER;
  252. RPTR:INTEGER;
  253. LPTR:INTEGER;
  254. CPTR:INTEGER;
  255.  
  256. (*    STRINGS[STRINGSMIN] RADIX INDICATOR
  257.     STRINGS[SYNTAXBASE] DEPTH OF NESTING &
  258.             CHECKSTACK POINTER    *)
  259. RSTACK:ARRAY[RSTACKMIN..RSTACKMAX] OF INTEGER;
  260. STACK:ARRAY[MSTACKMIN..PSTACKMAX] OF INTEGER;
  261. LSTACK:ARRAY[LSTACKMIN..LSTACKMAX] OF INTEGER;
  262. CSTACK:ARRAY[CSTACKMIN..CSTACKMAX] OF INTEGER;
  263. (* VSTACK LOCATED IN LOW RAM *)
  264.  
  265. FUNCTION MAX(M,N:INTEGER):INTEGER;
  266.     BEGIN
  267.     IF M>N
  268.     THEN MAX:=M
  269.     ELSE MAX:=N
  270.     END(*MAX*);
  271.  
  272. PROCEDURE ABORT;
  273. FORWARD;(*RECURSION NEEDED HERE ONLY FOR CARRET,BELOW:*)
  274.  
  275. PROCEDURE TTYI;
  276.     FORWARD;
  277.  
  278. FUNCTION POP:INTEGER;
  279.     FORWARD;
  280.  
  281.  
  282. PROCEDURE CARRET(*OUTPUTS A CR-LF SEQUENCE*);
  283. BEGIN
  284. WITH MEMORY DO BEGIN
  285.     IF RAM[USR+W*10]<>FALS
  286.     THEN    BEGIN
  287.         RAM[USR+W*18]:=RAM[USR+W*18]+1;
  288.         IF RAM[USR+W*18]=RAM[USR+W*17]
  289.         THEN    BEGIN
  290.             TTYI;
  291.             RAM[USR+W*18]:=0;
  292.             C:=CHR(POP);
  293.             IF (C='Q') OR (C='q') THEN ABORT;
  294.             END;
  295.         RAM[USR+W*20]:=0;
  296.         WRITELN(OUTPUT);
  297.         END;
  298.     IF RAM[USR+W*8]<>FALS THEN WRITELN(LIST);
  299. END(*WITH MEMORY*);
  300. END(*CARRET*);
  301.  
  302.  
  303. PROCEDURE SPACES(NUM:INTEGER);
  304. FORWARD; (* NEEDED BY TAB, BELOW: *)
  305.  
  306. PROCEDURE TAB;
  307.     BEGIN
  308. WITH MEMORY DO BEGIN
  309.     IF RAM[USR+W*23]>0
  310.     THEN SPACES(RAM[USR+W*23]-(RAM[USR+W*20] MOD RAM[USR+W*23]));
  311. END(*WITH MEMORY*);
  312.     END(*TAB*);
  313.  
  314. PROCEDURE CHOUT(CH:CHAR);
  315. (* OUTPUTS A CHARACTER*)
  316. BEGIN
  317. WITH MEMORY DO BEGIN
  318.     IF CH=CHR(NEWLINE) THEN CARRET
  319.     ELSE IF CH=CHR(9) THEN TAB
  320.     ELSE    BEGIN
  321.         IF RAM[USR+W*20]=RAM[USR+W*19] THEN CARRET;
  322.         RAM[USR+W*20]:=RAM[USR+W*20]+1;
  323.         IF RAM[USR+W*10]<>FALS THEN WRITE(OUTPUT,CH);
  324.         IF RAM[USR+W*8]<>FALS THEN WRITE(LIST,CH);
  325.         END
  326. END(*WITH MEMORY*);
  327. END(*CHOUT*);
  328.  
  329. PROCEDURE SPACES;
  330.     BEGIN
  331.     WHILE NUM>0 DO
  332.         BEGIN
  333.         CHOUT(' ');
  334.         NUM:=NUM-1;
  335.         END(*WHILE*)
  336.     END(*SPACES*);
  337.  
  338.  
  339. PROCEDURE MESSAGE(ST:INTEGER);
  340.     VAR LAST:INTEGER;
  341.     BEGIN
  342. WITH MEMORY DO BEGIN
  343.     IF ORD(STRINGS[ST])>0 THEN
  344.         BEGIN
  345.         LAST:=ST+ORD(STRINGS[ST]);
  346.         REPEAT
  347.             ST:=ST+1;
  348.             CHOUT(STRINGS[ST]);
  349.         UNTIL ST=LAST;
  350.         END(*IF*)
  351. END(*WITH MEMORY*);
  352.     END(*MESSAGE*);
  353.  
  354. PROCEDURE INTERPRET(I:INTEGER);
  355.     FORWARD;(*NEEDED IN ABORT,PROMPT
  356.         FOR USER SUPPLIED PATCHES*)
  357.  
  358. PROCEDURE ABORT;
  359. (*    RESETS STACKS
  360.     RETURNS I/O TO TTY:
  361.     PRODUCES SIGNON MSG    *)
  362.     BEGIN
  363. WITH MEMORY DO BEGIN
  364.     IP:=COMPBUF;(*SO RAM[IP] IS NOT OUT OF RANGE*)
  365.     RAM[USR+W*31]:=FALS;(*SESSION NOT DONE*)
  366.     RAM[USR+W*28]:=VBASE;
  367.     RAM[VBASE]:=USR+W*29;
  368.     RAM[USR+W*5]:=USR+W*29;
  369.     STKPTR := STACKMIN;
  370.     RPTR := RSTACKMIN-R;
  371.     CPTR := CSTACKMIN;
  372.     LPTR := LSTACKMIN;
  373.     STRINGS[SYNTAXBASE] := CHR(0);
  374.     RAM[USR+W*7]:=FALS;(*RETURN TO CONSOLE INPUT*)
  375.     RAM[USR+W*10]:=TRU;(*TURN ON CONSOLE OUTPUT*)
  376.     IF LISTNAME=NULLNAME THEN RAM[USR+W*8]:=FALS;
  377.     (*TURN OFF LISTING IF NO LISTFILE IS OPEN*)
  378.     MESSAGE(ID);
  379.     (* IFCR *)
  380.     IF RAM[USR+W*20]<>0 THEN CARRET;
  381.     RAM[USR+W*15]:=FALS;(*TURN TRACE OFF, IF NECESSARY*)
  382.     IF RAM[USR+W*34]<>FALS
  383.     THEN INTERPRET(RAM[USR+W*34]);(*USER SUPPLIED SUPPLEMENT TO ABORT*)
  384.     GOTO 99;
  385. END(*WITH MEMORY*);
  386.     END(*ABORT*);
  387.  
  388. PROCEDURE MERR(M:INTEGER);(*MESSAGE-ERROR*)
  389.     BEGIN
  390.     MEMORY.RAM[USR+W*10]:=TRU;(*TURN ON CONSOLE*)
  391.     (* IFCR *)
  392.     IF MEMORY.RAM[USR+W*20]>0 THEN CARRET;
  393.     MESSAGE(M);
  394.     ABORT;
  395.     END(*MERR*);
  396.  
  397. PROCEDURE SYNTERR;
  398.     BEGIN
  399. WITH MEMORY DO BEGIN
  400.     RAM[USR+W*10]:=TRU; (*TURN ON CONSOLE*)
  401.     (* IFCR *)
  402.     IF RAM[USR+W*20]>0 THEN CARRET;
  403.     IF (RAM[USR+W*7]<>FALS) AND (RAM[USR+W*9]=FALS) THEN MESSAGE(LINEBUF);
  404.     MERR(SYNT);
  405. END(*WITH MEMORY*);
  406.     END(*SYNTERR*);
  407.  
  408.  
  409.  
  410. PROCEDURE PUSH(ITEM:INTEGER);    (*PARAMETER STACK*)
  411.     BEGIN
  412.     STKPTR:=STKPTR+S;
  413.     IF STKPTR>=STACKMAX THEN MERR(OVFLO);
  414.     STACK[STKPTR]:=ITEM;
  415.     END(*PUSH*);
  416.  
  417. (*RSTACK USED FOR RETURN ADDRESSES ONLY;
  418.     NOT FOR CASE OR LOOP STRUCTURES*)
  419. PROCEDURE RPUSH(ITEM:INTEGER); (*ON RETURN STACK*)
  420.     BEGIN
  421.     RPTR:=RPTR+R;
  422.     IF RPTR>=RSTACKMAX THEN MERR(OVFLO);
  423.     RSTACK[RPTR]:=ITEM;
  424.     END(*RPUSH*);
  425.  
  426. PROCEDURE LPUSH(ITEM:INTEGER);
  427.     BEGIN
  428.     LPTR:=LPTR+L;
  429.     IF LPTR>=LSTACKMAX THEN MERR(OVFLO);
  430.     LSTACK[LPTR]:=ITEM;
  431.     END(*LPUSH*);
  432.  
  433. PROCEDURE CPUSH(ITEM:INTEGER);(*FOR CASE STACK*)
  434.     BEGIN
  435.     CPTR:=CPTR+CSTEP;
  436.     IF CPTR>=CSTACKMAX THEN MERR(OVFLO);
  437.     CSTACK[CPTR]:=ITEM;
  438.     END(*CPUSH*);
  439.  
  440.  
  441. PROCEDURE PUSHCK(CHKCH:CHAR);    (*PLACE ON CHARACTER CHECK STACK*)
  442.     BEGIN
  443. WITH MEMORY DO BEGIN
  444.     STRINGS[SYNTAXBASE]:= CHR(ORD(STRINGS[SYNTAXBASE])+1);
  445.     IF ORD(STRINGS[SYNTAXBASE])<CHKLMT
  446.     THEN STRINGS[ORD(STRINGS[SYNTAXBASE])+SYNTAXBASE] := CHKCH
  447.     ELSE    BEGIN
  448.         RAM[USR+W*10]:=TRU; (*TURN ON CONSOLE*)
  449.         MESSAGE(OVFLO);
  450.         SYNTERR;
  451.         END
  452. END(*WITH MEMORY*);
  453.     END(*PUSHCK*);
  454.  
  455. PROCEDURE TTYI;    (* FOR TYI *)
  456.     VAR C:CHAR;
  457.     BEGIN
  458.     IF KEYCURS>KEYLEN
  459.     THEN    BEGIN
  460.         READLN(INPUT);
  461.         KEYLEN:=0;
  462.         WHILE NOT EOLN(INPUT)
  463.         DO     BEGIN
  464.             READ(INPUT,C);
  465.             KEYSTRING[KEYLEN]:=C;
  466.             KEYLEN:=KEYLEN+1;
  467.             END;
  468.         KEYSTRING[KEYLEN]:=CHR(NEWLINE);
  469.         KEYCURS:=0;
  470.         END(*IF*);
  471.     PUSH(ORD(KEYSTRING[KEYCURS]));
  472.     KEYCURS:=KEYCURS+1;
  473.     END(*TTYI*);
  474.  
  475. PROCEDURE APPEND(ITEM:INTEGER); (*PUT ITEM AT END OF DICTIONARY*)
  476.     BEGIN
  477. WITH MEMORY DO BEGIN
  478.     RAM[RAM[USR+W*2]] := ITEM;
  479.     RAM[USR+W*2] := RAM[USR+W*2]+W;
  480.     IF RAM[USR+W*2]>=COMPBUF THEN MERR(WRITV);
  481. END(*WITH MEMORY*);
  482.     END(*APPEND*);
  483.  
  484.  
  485.  
  486. PROCEDURE ALOOP;(*USED BY (LOOP) AND BY (+LOOP) *)
  487.     BEGIN
  488.     IF LSTACK[LPTR]<LSTACK[LPTR-L]
  489.     THEN (*BRANCH*) IP:=IP+MEMORY.RAM[IP]
  490.     ELSE    BEGIN
  491.         LPTR:=LPTR-L*3;
  492.         IF LPTR<LSTACKMIN THEN MERR(UNDFLO);
  493.         (*SKIP*) IP:=IP+W
  494.         END
  495.     END(*ALOOP*);
  496.  
  497.  
  498. FUNCTION POP; (*LARGELY REPLACES DROP*)
  499.     BEGIN
  500.     IF STKPTR<S+STACKMIN THEN MERR(UNDFLO)
  501.     ELSE    BEGIN
  502.         POP:=STACK[STKPTR];
  503.         STKPTR:=STKPTR-S;
  504.         END
  505.     END(*POP*);
  506.  
  507. PROCEDURE PDO;(* (DO) *)
  508. VAR STRT,ND:INTEGER;
  509.     BEGIN
  510.     STRT:=POP;
  511.     ND:=POP;
  512.     IF STRT<ND
  513.     THEN    BEGIN
  514.         LPUSH(STRT);
  515.         LPUSH(ND);
  516.         LPUSH(STRT);(*ITERATION VAR*)
  517.         (*SKIP*) IP:=IP+W
  518.         END
  519.     ELSE (*BRANCH*) IP:=IP+MEMORY.RAM[IP]
  520.     END(*PDO*);
  521.  
  522.  
  523. PROCEDURE DROPCK;
  524.     BEGIN
  525. WITH MEMORY DO BEGIN
  526.     IF ORD(STRINGS[SYNTAXBASE])>0
  527.     THEN STRINGS[SYNTAXBASE] := CHR(ORD(STRINGS[SYNTAXBASE])-1)
  528.     ELSE SYNTERR
  529. END(*WITH MEMORY*);
  530.     END(*DROPCK*);
  531.  
  532.  
  533. PROCEDURE VFIND;
  534. (*PTOKEN POINTS TO THE LOCATION IN STRINGS THAT
  535.     THE START OF THE TOKEN IS;  THIS TOKEN
  536.     IS LOOKED UP IN VOCABULARY POINTED TO BY THE TOS
  537.     AND THE ADDRESS IS RETURNED BY  THE TOS  *)
  538. VAR    LOC:INTEGER;
  539.     PTOKEN:INTEGER;
  540.  
  541. (*RETURNS POINTER TO PF IF MATCHED OTHERWISE LOC:=0*)
  542.         LEN,TEM:INTEGER;
  543.         MATCH:BOOLEAN;
  544.         PREV:INTEGER;
  545.  
  546.     BEGIN
  547. WITH MEMORY DO BEGIN
  548.     LOC:=RAM[POP];
  549.         PREV:=LOC;
  550.     PTOKEN:=POP;
  551.     IF (PTOKEN<STRINGSMIN) OR (PTOKEN>LINEBUF)
  552.     THEN MERR(READV);(*READ_PROTECT*)
  553.     LEN:=ORD(STRINGS[PTOKEN]);
  554.     IF LOC<>FALS THEN
  555.     REPEAT
  556.         MATCH:=TRUE;
  557.         IF STRINGS[RAM[LOC-W*2]]=CHR(LEN)
  558.         THEN    BEGIN
  559.             TEM:=0;
  560.             REPEAT
  561.                 TEM:=TEM+1;
  562.             UNTIL (STRINGS[RAM[LOC-W*2]+TEM])
  563.                 <>(STRINGS[PTOKEN+TEM]);
  564.             IF TEM<(LEN+1) THEN
  565.                 MATCH:=FALSE;
  566.             END(*THEN*)
  567.         ELSE MATCH:=FALSE;
  568.     IF NOT MATCH THEN BEGIN PREV:=LOC;
  569.                 LOC:=RAM[LOC-W*3]
  570.               END;
  571.     UNTIL (MATCH) OR (LOC=FALS);
  572.     PUSH(LOC);
  573.     RAM[USR+W*6]:=PREV;
  574. END(*WITH MEMORY*);
  575.     END(*VFIND*);
  576.  
  577.  
  578. PROCEDURE FIND;
  579. VAR V:INTEGER;
  580.     PTOKEN:INTEGER;
  581.     LOC:INTEGER;
  582. BEGIN
  583.     PTOKEN:=POP;
  584.     V:=MEMORY.RAM[USR+W*28];
  585.     REPEAT
  586.     PUSH(PTOKEN);
  587.     PUSH(MEMORY.RAM[V]);
  588.     VFIND;
  589.     LOC:=POP;
  590.     V:=V-W;
  591.     UNTIL (V<VBASE) OR (LOC<>FALS);
  592.     PUSH(LOC);
  593. END(*FIND*);
  594.  
  595. (* HEADER:     ENDA:CODE END,NORMALLY POINTS TO RET
  596.           LINK :PREVIOUS EXECA
  597.         NFA:STRINGS
  598.           COMPA:CF
  599.           EXECA:PF        *)
  600. PROCEDURE ENTER(*CREATES AN ENTRY FOR TOKEN POINTED TO 
  601.         BY TOP OF PARAMETER STACK*);
  602. VAR PTKN:INTEGER;
  603.     BEGIN
  604. WITH MEMORY DO BEGIN
  605.     PTKN:=STACK[STKPTR];;
  606.     FIND;
  607.     IF POP<>FALS THEN
  608.         BEGIN
  609.         MESSAGE(REDEF);
  610.         SPACES(3);
  611.         MESSAGE(PTKN);
  612.         CARRET
  613.         END(*IF*);
  614.     APPEND(0);(*FOR ENDA*)
  615.     APPEND(RAM[RAM[USR+W*5]]);
  616.     APPEND(PTKN);
  617.     APPEND(COMPHERE);(* (:) *)
  618.     RAM[RAM[USR+W*5]]:=RAM[USR+W*2];(*CURRENT:=EXECA*)
  619. END(*WITH MEMORY*);
  620.     END(*ENTER*);
  621.  
  622. PROCEDURE FENTER;(*FINISH MOST RECENT ENTRY
  623.             FILLING IN ENDA WITH I *)
  624.     BEGIN
  625.     WITH MEMORY DO BEGIN
  626.     RAM[RAM[RAM[USR+W*5]]-W*4] := POP
  627.     END(*WITH MEMORY*)
  628.     END(*FENTER*);
  629.  
  630. PROCEDURE GEOLN;
  631. (* ADVANCES TO EOLN*)
  632.     BEGIN
  633.     WITH MEMORY DO
  634.     RAM[USR+W*11]:=ORD(STRINGS[LINEBUF])+LINEBUF;
  635.     END(*GEOLN*);
  636.  
  637. PROCEDURE GETLINE;
  638. (*BUFFERS INPUT LINE INTO STRINGS[LINEBUF]*)
  639. VAR CH:CHAR;
  640. BEGIN(*GETLINE*)
  641. WITH MEMORY DO BEGIN
  642.     RAM[USR+W*12]:=0;(*LINELENGTH*)
  643.     RAM[USR+W*11]:=LINEBUF;
  644.     IF RAM[USR+W*7]=FALS
  645.     THEN    BEGIN
  646.         READLN(INPUT);
  647.         KEYCURS:=1+KEYLEN;(*RESET FOR TTYI*)
  648.         WHILE NOT EOLN(INPUT) DO
  649.             BEGIN
  650.             READ(INPUT,CH);
  651.             IF RAM[USR+W*8]<>FALS
  652.                 THEN WRITE(LIST,CH);
  653.             RAM[USR+W*12]:=RAM[USR+W*12]+1;
  654.             RAM[USR+W*11]:=RAM[USR+W*11]+1;
  655.             STRINGS[RAM[USR+W*11]]:=CH;
  656.             END(*WHILE*);
  657.  
  658.         IF RAM[USR+W*8]<>FALS
  659.             THEN WRITELN(LIST);
  660.         END(*THEN*);
  661.     IF RAM[USR+W*7]<>FALS    (* CANNOT BE USED TO LOAD FROM EDITBUF*)
  662.     THEN    BEGIN
  663.         IF EOF(LDFIL) THEN MERR(FEOF);
  664.         WHILE NOT EOLN(LDFIL) DO
  665.             BEGIN
  666.             READ(LDFIL,CH);
  667.             RAM[USR+W*12]:=RAM[USR+W*12]+1;
  668.             RAM[USR+W*11]:=RAM[USR+W*11]+1;
  669.             STRINGS[RAM[USR+W*11]]:=CH;
  670.             END(*WHILE*);
  671.         READLN(LDFIL);
  672.         IF EOF(LDFIL)    THEN RAM[USR+W*25]:=-RAM[USR+W*25]
  673.                 ELSE RAM[USR+W*25]:=RAM[USR+W*25]+1;
  674.         END(*THEN*);
  675.     STRINGS[LINEBUF]:=CHR(RAM[USR+W*12]+1);
  676.     STRINGS[RAM[USR+W*11]+1]:=CHR(NEWLINE);
  677.     RAM[USR+W*11]:=LINEBUF+1;
  678.     (**ECHO:**)
  679.     IF (RAM[USR+W*9]<>FALS) AND (RAM[USR+W*7]<>FALS)
  680.     THEN MESSAGE(LINEBUF);
  681.  
  682. END(*WITH MEMORY*);
  683. END(*GETLINE*);
  684.  
  685.  
  686.  
  687.  
  688.  
  689.  
  690. PROCEDURE MOVE;
  691. (*    AS:ADDRESS OF SOURCE BLOCK
  692.     AD:ADDRESS OF DESTINATION
  693.       NOWD:NUMBER OF WORDS*W TO BE MOVED    *)
  694.  
  695.     VAR ENDADDR:INTEGER;
  696.         AS,AD,NOWD:INTEGER;
  697.     BEGIN(*MOVE*)
  698.     NOWD:=POP;
  699.     AD:=POP;
  700.     AS:=POP;
  701.     ENDADDR:=AS+NOWD;
  702.     IF (AS<RAMMIN) OR (ENDADDR>RAMMAX) THEN MERR(READV);
  703.     IF (AD<0) OR (AD+NOWD>RAMMAX) THEN MERR(WRITV);
  704.     REPEAT
  705.         MEMORY.RAM[AD]:=MEMORY.RAM[AS];
  706.         AD:=AD+W;
  707.         AS:=AS+W;
  708.     UNTIL AS>ENDADDR
  709.     END(*MOVE*);
  710.  
  711. FUNCTION SLIT:INTEGER;
  712. (* EMPLACES THE TOKEN POINTED TO BY RAM[USR+W*3] INTO
  713.     STRINGS AND POINTS TO ITS START*)
  714.  
  715.     VAR START,LENGTH, I:INTEGER;
  716.     BEGIN
  717. WITH MEMORY DO BEGIN
  718.     START:=RAM[USR+W*3];
  719.     LENGTH:=ORD(STRINGS[START])-1;
  720.     FOR I:= 1 TO LENGTH
  721.         DO STRINGS[START+I]:=STRINGS[START+I+1];
  722.     STRINGS[START]:=CHR(LENGTH);
  723.     RAM[USR+W*3]:=RAM[USR+W*3]+LENGTH+1
  724. END(*WITH MEMORY*);
  725.     SLIT:=START;
  726.     END(*SLIT*);
  727.  
  728. PROCEDURE SWAP;(*TOP TWO ITEMS ON PARAMETER STACK*)
  729. VAR HOLD:INTEGER;
  730.     BEGIN
  731.     HOLD:=STACK[STKPTR];
  732.     STACK[STKPTR]:=STACK[STKPTR-S];
  733.     STACK[STKPTR-S]:=HOLD
  734.     END(*SWAP*);
  735.  
  736.  
  737. PROCEDURE NEXTCH;
  738. (*ADVANCES POINTER, RAM[USR+W*11] TO NEXT CHARACTER IN
  739.     BUFFERED INPUT LINE; WILL NOT ADVANCE BEYOND
  740.     A CARRIAGE RETURN *)
  741.  
  742.     BEGIN
  743. WITH MEMORY DO BEGIN
  744.     IF STRINGS[RAM[USR+W*11]] <> CHR(NEWLINE)
  745.     THEN RAM[USR+W*11]:=RAM[USR+W*11]+1;
  746.  
  747. END(*WITH MEMORY*);
  748.     END(*NEXTCH*);
  749.  
  750. PROCEDURE PROMPT;
  751.     BEGIN
  752. WITH MEMORY DO BEGIN
  753.     IF RAM[USR+W*32]<>FALS THEN INTERPRET(RAM[USR+W*32])(*SPECIAL USER PROMPT*)
  754.     ELSE
  755.     BEGIN(*PRIMITIVE PROMPT*)
  756.     (* IFCR *)
  757.     IF RAM[USR+W*20]>0 THEN CARRET;
  758.     CHOUT(STRINGS[STRINGSMIN]);
  759.     MESSAGE(SYNTAXBASE);
  760.     CHOUT('>');
  761.     END(*STANDARD PROMPT*)
  762. END(*WITH MEMORY*);
  763.     END(*PROMPT*);
  764.  
  765. PROCEDURE IGNRBLNKS;
  766. (*ADVANCES RAM[USR+W*11] TO POINT TO NEXT NON-BLANK, ETC.
  767.     CHARACTER IN BUFFERED INPUT LINE; WILL NOT
  768.     ADVANCE BEYOND A CARRIAGE RETURN*)
  769. BEGIN WITH MEMORY DO
  770.     WHILE ORD(STRINGS[RAM[USR+W*11]]) IN [9,32]
  771.         DO NEXTCH
  772. END(*IGNRBLNKS*);
  773.  
  774. PROCEDURE LONGSTRING(VAR START:INTEGER);
  775. (*EMPLACES "STRING" POINTED TO BY RAM[USR+W*14] INTO STRINGS
  776.     AND POINTS TO ITS START*)
  777.  
  778.     VAR LENGTH:INTEGER;
  779.     BEGIN(*LONGSTRING*)
  780. WITH MEMORY DO BEGIN
  781.     IF STRINGS[RAM[USR+W*14]]<>'"' THEN ABORT;
  782.     START:=RAM[USR+W*3];
  783.     LENGTH:=0;
  784.     RAM[USR+W*11]:=RAM[USR+W*14]+1; (*RESET NEXTCH POINTER*)
  785.     WHILE NOT(ORD(STRINGS[RAM[USR+W*11]]) IN [NEWLINE,34])
  786.      DO    BEGIN
  787.         LENGTH := LENGTH+1;
  788.         STRINGS[START+LENGTH]:=STRINGS[RAM[USR+W*11]];
  789.         NEXTCH;
  790.         END(*WHILE NOT*);
  791.     NEXTCH;
  792.     STRINGS[START]:=CHR(LENGTH);
  793.     RAM[USR+W*3]:=START+LENGTH+1;
  794.  
  795. END(*WITH MEMORY*);
  796.     END(*LONGSTRING*);
  797.  
  798. PROCEDURE INTOKEN;
  799. (* PLACES STRING AT END OF STRINGS SO THAT
  800.     RAM[USR+W*3] POINTS TO IT *)
  801.     VAR CHRCNT:INTEGER;
  802.  
  803.     BEGIN
  804. WITH MEMORY DO BEGIN
  805.     CHRCNT:=0;
  806.     REPEAT
  807.         CHRCNT:=CHRCNT+1;
  808.         IF (STRINGS[RAM[USR+W*11]]>='a')
  809.             AND (STRINGS[RAM[USR+W*11]]<='z')
  810.             AND (RAM[USR+W*13]<>FALS)
  811.         THEN(*RAISE TO UPPERCASE*)
  812.             STRINGS[CHRCNT+RAM[USR+W*3]]:=
  813.                 CHR(ORD(STRINGS[RAM[USR+W*11]])-32)
  814.         ELSE(*NO NEED TO RAISE*)
  815.         STRINGS[CHRCNT+RAM[USR+W*3]]:=
  816.             STRINGS[RAM[USR+W*11]];
  817.         NEXTCH
  818.     UNTIL ORD(STRINGS[RAM[USR+W*11]]) IN [0,9,10,13,32];
  819.     STRINGS[RAM[USR+W*3]]:=CHR(CHRCNT);
  820. END(*WITH MEMORY*);
  821.     END(*INTOKEN*);
  822.  
  823. FUNCTION DIGIT(D:INTEGER):INTEGER;
  824. (*CONVERTS ORD(ASCII) INTO NUMERICAL EQUIVALENT*)
  825. (*ERROR CONDITION FOR ARGUMENT PRODUCES NEGATIVE RESULT*)
  826.     BEGIN
  827.     IF D<=ORD('9')
  828.         THEN DIGIT:=D-ORD('0')
  829.     ELSE IF D<ORD('A')
  830.         THEN DIGIT:=-1
  831.     ELSE IF D<=ORD('Z')
  832.         THEN DIGIT:=10+D-ORD('A')
  833.     ELSE DIGIT:=-1
  834.     END(*DIGIT*);
  835.  
  836. PROCEDURE COMPILE(ADDRESS:INTEGER);
  837. (*"PUSHES" ADDRESS ONTO COMPILE BUFFER "STACK"*)
  838.  
  839.     BEGIN
  840. WITH MEMORY DO BEGIN
  841.     RAM[RAM[USR+W*1]]:=ADDRESS;
  842.     RAM[USR+W*1]:=RAM[USR+W*1]+W;
  843.     IF RAM[USR+W*1]>=RAMMAX THEN MERR(WRITV) ;
  844. END(*WITH MEMORY*);
  845.     END(*COMPILE*);
  846.  
  847. PROCEDURE FWDREF;(*COMPILES 0 TO PROVIDE SPACE FOR TOUCHUP TO USE*)
  848.     BEGIN
  849.     PUSH(MEMORY.RAM[USR+W*1]);
  850.     COMPILE(0);(*TO BE OVERWRITTEN*)
  851.     END(*FWDREF*);
  852.  
  853.  
  854.  
  855. FUNCTION CONVERT(PTKN:INTEGER;BASE:INTEGER;
  856.             VAR VALUE:INTEGER):BOOLEAN;
  857. (*INPUT NUMBER CONVERSION ROUTINE*)
  858.  
  859.     VAR TEND:INTEGER(*TOKEN END*);
  860.         SIGN:INTEGER;
  861.         CURSOR:INTEGER;
  862.  
  863.     BEGIN
  864. WITH MEMORY DO BEGIN
  865.     VALUE:=0;
  866.     SIGN:=+1;
  867.     TEND:=ORD(STRINGS[PTKN])+PTKN+1;
  868.     IF STRINGS[PTKN+1]='+'THEN CURSOR:=PTKN+2
  869.     ELSE IF STRINGS[PTKN+1]='-' THEN
  870.         BEGIN SIGN:=-1;
  871.             CURSOR:=PTKN+2
  872.         END
  873.     ELSE CURSOR:=PTKN+1;
  874.     WHILE(DIGIT(ORD(STRINGS[CURSOR]))<BASE) AND
  875.         (DIGIT(ORD(STRINGS[CURSOR]))>-1) AND (CURSOR<TEND)
  876.       DO    BEGIN
  877.         VALUE:=BASE*VALUE+DIGIT(ORD(STRINGS[CURSOR]));
  878.         CURSOR:=CURSOR+1;
  879.         END;
  880.     VALUE:=VALUE*SIGN;
  881.     IF CURSOR=TEND
  882.     THEN CONVERT:=TRUE
  883.     ELSE CONVERT:=FALSE;
  884. END(*WITH MEMORY*);
  885.     END(*CONVERT*);
  886.  
  887. PROCEDURE TOUCHUP;(*FOR FORWARD REFERENCES*)
  888. (*OVERWRITES 0 LEFT BY FWDREF WITH RELATIVE DISPLACEMENT
  889.     TO CURRENT LOCATION IN COMPILE BUFFER*)
  890. VAR REF:INTEGER;
  891.     BEGIN
  892.     REF:=POP;
  893.     MEMORY.RAM[REF]:=MEMORY.RAM[USR+W*1]-REF;
  894.     END(*TOUCHUP*);
  895.  
  896. PROCEDURE PERMSTRINGS;
  897. (* UPDATES RAM[USR+W*4] TO POINT TO NEW TOP OF PERMANENT
  898.     STRING AREA*)
  899.     BEGIN
  900.     WITH MEMORY DO
  901.     IF RAM[USR+W*4]<RAM[USR+W*3]
  902.     THEN RAM[USR+W*4]:=RAM[USR+W*3]
  903.     END(*PERMSTRINGS*);
  904.  
  905.  
  906. PROCEDURE FNAME(VAR NAME:DALFA);
  907. (* LOADS NAME FROM TOS FOR FILE I/O FUNCTIONS *)
  908. VAR    I:INTEGER;
  909.     TEND:INTEGER;
  910.     TOS:INTEGER;
  911. BEGIN
  912.     TOS:=POP;
  913.     IF (TOS<STRINGSMIN) OR (TOS>STRINGSMAX-20)THEN MERR(READV);
  914.     FOR I:=1 TO 20 DO NAME[I]:=CHR(0);
  915.     TEND:=ORD(MEMORY.STRINGS[TOS]);
  916.     IF TEND > 20 THEN ABORT;
  917.     FOR I:=1 TO TEND DO NAME[I]:=MEMORY.STRINGS[TOS+I];
  918. END(*FNAME*);
  919.  
  920. PROCEDURE PINT(INST:INTEGER);
  921. FORWARD;
  922.  
  923. PROCEDURE PINT0(INST:INTEGER);
  924. (*PRIMITIVE INTERPRETATION OF [0..40]*)
  925. VAR TOS:INTEGER;(*TOP OF STACK*)
  926.     NTT:INTEGER;(*NEXT TO TOP*)
  927. BEGIN
  928. WITH MEMORY DO BEGIN
  929. CASE INST OF
  930. PSEMICOLON:    (* (;) *)BEGIN
  931.             IP:=RSTACK[RPTR];
  932.             RPTR:=RPTR-R;
  933.             END(* (;) *);
  934.  
  935. WSTORE:    (* W! *)BEGIN
  936.         TOS:=POP;
  937.         IF (TOS<USR) OR (TOS>RAMMAX) THEN MERR(WRITV);
  938.         RAM[TOS]:=POP;
  939.         END;
  940. TIMES:    (*  *  *)
  941.     PUSH(POP*POP);
  942.  
  943. PLUS:    (* + *)
  944.     PUSH(POP+POP);
  945.  
  946. SUBTRACT:    (* - *)
  947.     BEGIN
  948.     TOS:=POP;
  949.     PUSH(POP-TOS)
  950.     END;
  951.  
  952. DIVMOD:    (* /MOD *)
  953.     BEGIN
  954.     TOS:=POP;
  955.     NTT:=POP;
  956.     IF TOS=0 THEN MERR(DIVBY0);
  957.     PUSH(NTT DIV TOS);
  958.     PUSH(NTT MOD TOS);
  959.     END(*DIVMOD*);
  960.  
  961. PIF:    (* 0BRANCH OR (IF) *)
  962.     BEGIN
  963.         IF 0=POP
  964.         THEN (*BRANCH*) IP:=IP+RAM[IP]
  965.         ELSE (*SKIP*) IP:=IP+W
  966.     END;
  967.  
  968. WAT:    (* W@ *)
  969.     BEGIN
  970.     TOS:=POP;
  971.     IF (TOS<RAMMIN) OR (TOS>RAMMAX) THEN MERR(READV);
  972.     PUSH(RAM[TOS])
  973.     END(*WAT:*);
  974.  
  975. ABRT:    ABORT;
  976.  
  977. SP:    (* SP *)
  978.     PUSH(STKPTR);
  979.  
  980. LOAD:    (* LOAD *)
  981.     BEGIN
  982.     TOS:=POP;
  983.     RAM[USR+W*7]:=TOS;
  984.     IF TOS>MAXLINNO
  985.     THEN    BEGIN
  986.         PUSH(TOS);
  987.         FNAME(INFIL);
  988.         RESET(LDFIL,INFIL);
  989.         RAM[USR+W*25]:=0;
  990.         END(*IF*)
  991.  
  992.     END(*LOAD:*);
  993.  
  994. PELSE:    (* BRANCH OR (ELSE) *)
  995.     IP:=IP+RAM[IP];
  996.  
  997. WRD:    (* W *)
  998.     PUSH(W);
  999.  
  1000. RP:    (* RP *)
  1001.     PUSH((RPTR-RSTACKMIN) DIV R);
  1002.  
  1003. DROPOP:    TOS:=POP;
  1004.  
  1005. PUSER:    (* USER *)
  1006.     PUSH(USR);
  1007.  
  1008. EXEC:    (* EXEC *)
  1009.     BEGIN
  1010.         TOS:=POP;
  1011.         IF(*PRIMITIVE?*)TOS<NUMINSTR
  1012.         THEN PINT(TOS)
  1013.         ELSE    BEGIN
  1014.             IF(TOS<RAMMIN)OR(TOS>RAMMAX) THEN MERR(READV);
  1015.             RPUSH(IP);
  1016.             IP:=TOS;
  1017.             END;
  1018.     END(*EXEC:*);
  1019.  
  1020. EXITOP:    (* EXIT *)
  1021.     IF LPTR<(LSTACKMIN+L*3) THEN ABORT
  1022.     ELSE LSTACK[LPTR]:=LSTACK[LPTR-L];
  1023.  
  1024.  
  1025. LIT,    (* LITERAL *)
  1026. STRLIT:    (* STRING-LITERAL *)
  1027.     (*USED TO PUSH FOLLOWING WORD ON PARAMETER STACK *)
  1028.     BEGIN
  1029.     PUSH(RAM[IP]);
  1030.     (*SKIP*) IP:=IP+W
  1031.     END(*LIT:,STRLIT:*);
  1032.  
  1033. RPOP:    (* R> *) (*POP THE TOP OF RSTACK ONTO STACK*)
  1034.     BEGIN
  1035.     PUSH(RSTACK[RPTR]);
  1036.     RPTR:=RPTR-R
  1037.     END(*RPOP:*);
  1038.  
  1039.  
  1040. SWP:    IF STKPTR>STACKMIN+S THEN SWAP
  1041.     ELSE MERR(UNDFLO);
  1042.  
  1043. TYI:    (* TYI *)
  1044.     TTYI;
  1045.  
  1046. TYO:    (* TYO *)
  1047.     CHOUT(CHR(POP));
  1048.  
  1049. RPSH:    (* <R *) (*OPPOSITE TO R> , ABOVE , RPOP: *)
  1050.     RPUSH(POP);
  1051.  
  1052.  
  1053. SEMICF:    (* ;F *)
  1054.     BEGIN
  1055.         (* IFCR *)
  1056.         IF RAM[USR+W*20]>0 THEN CARRET;
  1057.         IF(RAM[USR+W*7]<MAXLINNO)AND(RAM[USR+W*7]>0)
  1058.         THEN    BEGIN
  1059.             RAM[USR+W*7]:=RAM[USR+W*7]-1;
  1060.             WRITELN(OUTPUT);
  1061.             WRITELN(OUTPUT,' THROUGH LINE ',
  1062.                 RAM[USR+W*7]:3,'(DECIMAL) LOADED');
  1063.             IF RAM[USR+W*8]<>FALS THEN
  1064.             BEGIN
  1065.             WRITELN(LIST);
  1066.             WRITELN(LIST,' THROUGH LINE ',
  1067.                 RAM[USR+W*7]:3,'(DECIMAL) LOADED');
  1068.             END(*IF RAM[USR+W*8]<>FALS*)
  1069.             END(*<MAXLINNO*);
  1070.         IF (RAM[USR+W*7]>=MAXLINNO)
  1071.         THEN    BEGIN
  1072.             WRITELN(OUTPUT,INFIL,' LOADED');
  1073.             IF RAM[USR+W*8]<>FALS THEN WRITELN(LIST,INFIL,' LOADED');
  1074.             END(* >=MAXLINNO *);
  1075.         RAM[USR+W*7]:=0;
  1076.     END(*SEMICF:*);
  1077.  
  1078. RAT:    (* R@ *)
  1079.     BEGIN
  1080.     TOS:=RPTR-R*POP;
  1081.     IF(TOS<RSTACKMIN) THEN MERR(READV);
  1082.     PUSH(RSTACK[TOS]);
  1083.     END(*RAT:*);
  1084.  
  1085. COMPME:    (*COMPILEME: COMPILES FOLLOWING CODE UNTIL ENDA
  1086.     VALUE IS REACHED; USED FOR PRIMITIVE-NOTIMMED.
  1087.     AND FOR MACR0($:)    *)
  1088.     (* IF (ENDA)=(EXECA) THEN NOTHING IS COMPILED *)
  1089.     BEGIN
  1090.     I:=IP;
  1091.     WHILE (I<RAM[IP-W*4])
  1092.     DO    BEGIN
  1093.         COMPILE(RAM[I]);
  1094.         I:=I+W;
  1095.         END;
  1096.     IP:=RSTACK[RPTR];
  1097.     RPTR:=RPTR-R;
  1098.     END(*COMPME:*);
  1099.  
  1100. COMPHERE:    (*NOTIMMED -- USED BY COMPILER DURING COMPILETIME ONLY*)
  1101.     BEGIN    COMPILE(IP);
  1102.     IP:=RSTACK[RPTR];
  1103.     RPTR:=RPTR-R;
  1104.     END(*COMPHERE:*);
  1105.  
  1106. DOLLARC:    (* $: *)
  1107.     BEGIN
  1108.     PUSHCK('$');
  1109.     COMPILE(PDOLLAR);(* ($:) *)
  1110.     FWDREF
  1111.     END;
  1112.  
  1113. COLON:    (* : *)
  1114.     BEGIN
  1115.     PUSHCK(':');
  1116.     COMPILE(PCOLON); (* (:) *)
  1117.     FWDREF;
  1118.     END;
  1119.  
  1120. SEMICOLON:    (* ; *)
  1121.     IF STRINGS[ORD(STRINGS[SYNTAXBASE])+SYNTAXBASE]=':'
  1122.     THEN    BEGIN
  1123.         DROPCK;
  1124.         COMPILE(PSEMICOLON);(* (;) *)
  1125.         TOUCHUP;
  1126.         END
  1127.     ELSE SYNTERR;
  1128.  
  1129. IFOP:    (* IF *)
  1130.     BEGIN
  1131.     PUSHCK('F');
  1132.     COMPILE(PIF);(* (IF) *)
  1133.     FWDREF;
  1134.     END;
  1135.  
  1136. ELSEOP:    (* ELSE *)
  1137.     IF STRINGS[ORD(STRINGS[SYNTAXBASE])+SYNTAXBASE] = 'F'
  1138.     THEN    BEGIN
  1139.         STRINGS[ORD(STRINGS[SYNTAXBASE])+SYNTAXBASE]:='E';
  1140.         COMPILE(PELSE);(* (ELSE) *)
  1141.         FWDREF;
  1142.         SWAP;
  1143.         TOUCHUP;
  1144.         END
  1145.     ELSE    SYNTERR;
  1146.  
  1147. THENOP:    (* THEN *)
  1148.     IF    (STRINGS[ORD(STRINGS[SYNTAXBASE])+SYNTAXBASE] = 'F')
  1149.     OR    (STRINGS[ORD(STRINGS[SYNTAXBASE])+SYNTAXBASE] = 'E')
  1150.     THEN    BEGIN
  1151.         DROPCK;
  1152.         TOUCHUP;
  1153.         END
  1154.     ELSE SYNTERR;
  1155.  
  1156. DOOP:    (* DO *)
  1157.     BEGIN
  1158.     PUSHCK('D');
  1159.     COMPILE(PDOOP);(* (DO) *)
  1160.     FWDREF;
  1161.     END;
  1162.  
  1163. LOOPOP:    (* LOOP *)
  1164.     IF STRINGS[ORD(STRINGS[SYNTAXBASE])+SYNTAXBASE]='D'
  1165.     THEN    BEGIN
  1166.         DROPCK;
  1167.         COMPILE(PLOOP);(* (LOOP) *)
  1168.         COMPILE(STACK[STKPTR]-RAM[USR+W*1]+W);
  1169.         TOUCHUP;
  1170.         END
  1171.     ELSE SYNTERR;
  1172.  
  1173. BEGINOP:    (* BEGIN *)
  1174.     BEGIN
  1175.     PUSHCK('B');
  1176.     PUSH(RAM[USR+W*1])
  1177.     END;
  1178.  
  1179. ENDOP:    (* END *)
  1180.     IF STRINGS[ORD(STRINGS[SYNTAXBASE])+SYNTAXBASE] = 'B'
  1181.     THEN    BEGIN
  1182.         DROPCK;
  1183.         COMPILE(PIF);(* (IF) *)
  1184.         COMPILE(POP-RAM[USR+W*1]);
  1185.         END
  1186.     ELSE SYNTERR;
  1187.  
  1188. REPET:    (* REPEAT *)
  1189.     BEGIN
  1190.     DROPCK;
  1191.     DROPCK;
  1192.     IF (STRINGS[ORD(STRINGS[SYNTAXBASE])+SYNTAXBASE+1]='B')
  1193.     AND(STRINGS[ORD(STRINGS[SYNTAXBASE])+SYNTAXBASE+2]='F')
  1194.     THEN    BEGIN
  1195.         COMPILE(PELSE);(* (ELSE) *)
  1196.         COMPILE(STACK[STKPTR-S]-RAM[USR+W*1]);
  1197.         TOUCHUP;(*TOUCHUP MODIFIES STACK*)
  1198.         TOS:=POP;
  1199.         END
  1200.     ELSE SYNTERR
  1201.     END(*REPET:*);
  1202.  
  1203. PERCENT:    (* % *)    GEOLN;
  1204.  
  1205. END(*CASE*)
  1206. END(*WITH MEMORY*);
  1207. END(*PINT0*);
  1208.  
  1209.  
  1210. PROCEDURE PINT1(INST:INTEGER);
  1211. (*PRIMITIVE INTERPRETATION OF [41..NUMINSTR-1]*)
  1212. VAR TOS,NTT,PARAM:INTEGER;(*TOP OF STACK*)
  1213.  
  1214.     PROCEDURE CRDMP;
  1215.     VAR SAVEFILE:IMFILE;(*CLOSED ON EXIT*)
  1216.     BEGIN
  1217.         FNAME(IMAGENAME);
  1218.         REWRITE(SAVEFILE,IMAGENAME);
  1219.         WRITE(SAVEFILE,MEMORY);
  1220.     END(*CRDMP*);
  1221.  
  1222.     PROCEDURE RSTOR;
  1223.     VAR SAVEFILE:IMFILE;
  1224.     BEGIN
  1225.         FNAME(IMAGENAME);
  1226.         RESET(SAVEFILE,IMAGENAME);
  1227.         READ(SAVEFILE,MEMORY);
  1228.         ABORT;
  1229.     END(*RSTOR*);
  1230.  
  1231. BEGIN
  1232. WITH MEMORY DO BEGIN
  1233.     CASE INST OF
  1234.  
  1235.  
  1236. PDOLLAR:    (* ($:) *)
  1237.     BEGIN(* SIMILAR TO PCOLON:,BELOW *)
  1238.     ENTER;(*CREATE HEADER*)
  1239.     PUSH(IP+W);
  1240.     PUSH(RAM[USR+W*2]);
  1241.     PUSH(RAM[IP]-W);
  1242.     MOVE;(*COPY CODE*)
  1243.     RAM[USR+W*2]:=RAM[USR+W*2]+RAM[IP]-W;(*UPDATE .D *)
  1244.     PUSH(RAM[USR+W*2]-W);
  1245.     FENTER;(*FINISH HEADER*)
  1246.     RAM[RAM[RAM[USR+W*5]]-W]:=COMPME;(*COMPILEME*)
  1247.     PERMSTRINGS;
  1248.     (*BRANCH*) IP:=IP+RAM[IP];
  1249.     END(*PDOLLAR:*);
  1250.  
  1251. PCOLON:    (* (:) *)
  1252.     BEGIN
  1253.     ENTER;(*CREATE HEADER*)
  1254.     PUSH(IP+W);
  1255.     PUSH(RAM[USR+W*2]);
  1256.     PUSH(RAM[IP]-W);
  1257.     MOVE(*COPY CODE*);
  1258.     RAM[USR+W*2]:=RAM[USR+W*2]+RAM[IP]-W;(*UPDATE .D *)
  1259.     PUSH(RAM[USR+W*2]-W);
  1260.     FENTER;(*FINISH HEADER*)
  1261.     PERMSTRINGS;
  1262.     (*BRANCH*) IP:=IP+RAM[IP];
  1263.     END(*PCOLON:*);
  1264.  
  1265. CASAT:    (* CASE@ *)
  1266.     (* similar to L@ , S@ , and R@ *)
  1267.     BEGIN
  1268.     TOS:=CSTEP*POP;
  1269.     IF CPTR<TOS THEN ABORT;
  1270.     PUSH(CSTACK[CPTR-TOS]);
  1271.     END(*CASAT:*);
  1272.  
  1273. PDOOP:    (* (DO) *)    PDO;
  1274.  
  1275. PPLOOP:    (* (+LOOP) *)
  1276.     BEGIN
  1277.     LSTACK[LPTR]:=LSTACK[LPTR]+POP;
  1278.     ALOOP;
  1279.     END(*PPLOOP:*);
  1280.  
  1281. PLLOOP:    (* +LOOP *)
  1282.     IF STRINGS[ORD(STRINGS[SYNTAXBASE])+SYNTAXBASE]='D'
  1283.     THEN    BEGIN
  1284.         DROPCK;
  1285.         COMPILE(PPLOOP);(* (+LOOP) *)
  1286.         COMPILE(STACK[STKPTR]-RAM[USR+W*1]+W);
  1287.         TOUCHUP;
  1288.         END
  1289.     ELSE SYNTERR;
  1290.  
  1291. CAT:    (* C@ *)
  1292.     BEGIN
  1293.     TOS:=POP;
  1294.     IF (TOS<STRINGSMIN) OR (TOS>STRINGSMAX) THEN MERR(READV);
  1295.     PUSH(ORD(STRINGS[TOS]));
  1296.     END(*CAT:*);
  1297.  
  1298. CSTORE:    (* C! *)
  1299.     BEGIN
  1300.     TOS:=POP;
  1301.     IF(TOS<STRINGSMIN)OR(TOS>STRINGSMAX) THEN MERR(WRITV);
  1302.     STRINGS[TOS]:=CHR(POP);
  1303.     END(*CSTORE:*);
  1304.  
  1305. PLOOP:    (* (LOOP) *)
  1306.     BEGIN
  1307.     LSTACK[LPTR]:=LSTACK[LPTR]+1;
  1308.     ALOOP;
  1309.     END;
  1310.  
  1311. DOTDOT: (* .. *)
  1312.     BEGIN
  1313.     TOS:=POP;NTT:=POP;PARAM:=POP;
  1314.     IF NTT<=TOS
  1315.     THEN    BEGIN
  1316.         IF(NTT<=PARAM)AND(PARAM<=TOS)
  1317.         THEN PUSH(TRU)
  1318.         ELSE PUSH(FALS)
  1319.         END
  1320.     ELSE    IF(NTT<=PARAM)OR(PARAM<=TOS)
  1321.         THEN PUSH(TRU)
  1322.         ELSE PUSH(FALS)
  1323.     END(*DOTDOT:*);
  1324.  
  1325. SEMIDOL:    (* ;$ *) (*VERY SIMILAR TO SEMICOLON:*)
  1326.     IF STRINGS[ORD(STRINGS[SYNTAXBASE])+SYNTAXBASE]='$'
  1327.     THEN    BEGIN
  1328.         DROPCK;
  1329.         COMPILE(PSEMICOLON);
  1330.         TOUCHUP;
  1331.         END
  1332.     ELSE    SYNTERR;
  1333.  
  1334.  
  1335. PRMQ:   (* PRIMITIVE? *)
  1336.     BEGIN
  1337.     TOS:=POP;
  1338.     IF (TOS>NUMINSTR) OR (TOS<0)
  1339.     THEN PUSH(FALS)
  1340.     ELSE PUSH(TRU)
  1341.     END(*PRMQ:*);
  1342.  
  1343. CORDMP:    (* COREDUMP *)
  1344.     CRDMP;
  1345.  
  1346. RESTOR:    (* RESTORE *)
  1347.     RSTOR;
  1348.  
  1349. SAT:    (* S@ *)(*GETS ITEMS OUT OF THE STACK*)
  1350.         (* 'DUP : 0 S@ ; *)
  1351.     BEGIN
  1352.     TOS:=S*POP;
  1353.     TEMP:=STKPTR-TOS;
  1354.     IF(TOS<0) OR (TEMP<=STACKMIN)
  1355.     THEN MERR(READV)
  1356.     ELSE PUSH(STACK[TEMP])
  1357.     END(*SAT:*);
  1358.  
  1359. FINDOP:    (* FIND *)
  1360.     FIND;
  1361.  
  1362. LISTFIL:    (* LISTFILE *)
  1363.     BEGIN
  1364.     WITH MEMORY DO BEGIN
  1365.     IF LISTNAME<>NULLNAME THEN
  1366.         WRITELN(OUTPUT,' CHANGING LISTFILE NAME FROM:',
  1367.             LISTNAME);
  1368.     FNAME(LISTNAME);
  1369.     REWRITE(LIST,LISTNAME);
  1370.     END(*WITH MEMORY*)
  1371.     END(*LISTFIL:*);
  1372.  
  1373. VFINDOP: VFIND;
  1374.  
  1375.  
  1376. LAT:    (* L@ *)(*SIMILAR TO S@, BUT FOR LOOP STACK*)
  1377.         (* 'I : 0 L@ ; *)
  1378.     BEGIN
  1379.         TOS:=L*POP;
  1380.         IF(LPTR<TOS) OR (LPTR<0) THEN MERR(READV);
  1381.         PUSH(LSTACK[LPTR-TOS]);
  1382.     END(*LAT:*);
  1383. OFCAS:    (* OFCASE *)
  1384.     BEGIN
  1385.     PUSHCK('C');
  1386.     COMPILE(POFCAS);(* (OFCASE) *)
  1387.     FWDREF;
  1388.     END(*OFCAS:*);
  1389.  
  1390. CCOLON:    (* C: *)
  1391.     IF STRINGS[ORD(STRINGS[SYNTAXBASE])+SYNTAXBASE]='C'
  1392.     THEN    BEGIN
  1393.         PUSHCK('c');
  1394.         COMPILE(PCCOL);(* (C:) *)
  1395.         FWDREF;
  1396.         END
  1397.     ELSE    SYNTERR;
  1398.  
  1399. SEMICC:    (* ;C *)
  1400.     IF STRINGS[ORD(STRINGS[SYNTAXBASE])+SYNTAXBASE]='c'
  1401.     THEN    BEGIN
  1402.         DROPCK;
  1403.         COMPILE(PSEMICC);(* (;C) *)
  1404.         TOUCHUP
  1405.         END
  1406.     ELSE    SYNTERR;
  1407.  
  1408. NDCAS:    (* ENDCASE *)
  1409.     IF STRINGS[ORD(STRINGS[SYNTAXBASE])+SYNTAXBASE]='C'
  1410.     THEN    BEGIN
  1411.         DROPCK;
  1412.         COMPILE(RAM[USR+W*21]);
  1413.         TOUCHUP;
  1414.         END
  1415.     ELSE    SYNTERR;
  1416.  
  1417. POFCAS:    (* (OFCASE) *)
  1418.     BEGIN
  1419.     IF STKPTR<S THEN MERR(UNDFLO);
  1420.     CPUSH(IP+RAM[IP]);
  1421.     CPUSH(STACK[STKPTR]);
  1422.     (*SKIP*) IP:=IP+W;
  1423.     END(*POFCAS:*);
  1424.  
  1425. PCCOL:    (* (C:) *)
  1426.     IF POP=FALS
  1427.     THEN    BEGIN
  1428.         PUSH(CSTACK[CPTR]);
  1429.         (*BRANCH*) IP:=IP+RAM[IP];
  1430.         END
  1431.     ELSE (*SKIP*) IP:=IP+W;
  1432.  
  1433. PSEMICC:    (* (;C) *)
  1434.     BEGIN
  1435.     CPTR:=CPTR-CSTEP*2;
  1436.     IF CPTR<CSTACKMIN THEN ABORT;
  1437.     IP:=CSTACK[CPTR+CSTEP];
  1438.     END(*PSEMICC66:*);
  1439.  
  1440. GTLIN:    GETLINE;
  1441.  
  1442. WORD:    (* WORD *)
  1443.     INTOKEN;
  1444.  
  1445. OPENR:    (* OPENR *)
  1446.     BEGIN
  1447.     FNAME(NAMEIN);
  1448.     RESET(EDIN,NAMEIN);
  1449.     RAM[USR+W*26]:=0;
  1450.     END(*OPENR*);
  1451.  
  1452. OPENW:    (* OPENW *)
  1453.     BEGIN
  1454.     FNAME(NAMOUT);
  1455.     REWRITE(EDOUT,NAMOUT);
  1456.     RAM[USR+W*27]:=0;
  1457.     END(*OPENW:*);
  1458.  
  1459. READL:    (* READLINE *)
  1460.     BEGIN
  1461.     RAM[USR+W*12]:=0;
  1462.     RAM[USR+W*11]:=LINEBUF;
  1463.     IF RAM[USR+W*26]<0 THEN MERR(FEOF);
  1464.     WHILE NOT EOLN(EDIN)
  1465.     DO    BEGIN
  1466.         READ(EDIN,C);
  1467.         RAM[USR+W*12]:=RAM[USR+W*12]+1;
  1468.         RAM[USR+W*11]:=RAM[USR+W*11]+1;
  1469.         STRINGS[RAM[USR+W*11]]:=C;
  1470.         END(*WHILE*);
  1471.     READLN(EDIN);
  1472.     IF EOF(EDIN)    THEN RAM[USR+W*26]:=-RAM[USR+W*26]-1
  1473.             ELSE RAM[USR+W*26]:=RAM[USR+W*26]+1;
  1474.     STRINGS[LINEBUF]:=CHR(RAM[USR+W*12]+1);
  1475.     STRINGS[RAM[USR+W*11]+1]:=CHR(NEWLINE);
  1476.     RAM[USR+W*11]:=LINEBUF+1;
  1477.     IF RAM[USR+W*9]<>FALS THEN MESSAGE(LINEBUF);
  1478.     END(*READL:*);
  1479.  
  1480. WRITL:    (* WRITELINE *)
  1481.     BEGIN
  1482.     IF RAM[USR+W*27]>0 THEN MERR(NOPEN);
  1483.     TOS:=POP;
  1484.     TEMP:=TOS+ORD(STRINGS[TOS])-1;
  1485.     WHILE TOS < TEMP
  1486.     DO    BEGIN
  1487.         TOS:=TOS+1;
  1488.         WRITE(EDOUT,STRINGS[TOS]);
  1489.         END(*WHILE*);
  1490.     WRITELN(EDOUT);
  1491.     RAM[USR+W*27]:=RAM[USR+W*27]-1;(*INCREASE NEGATIVE*)
  1492.     END(*WRITL*);
  1493.  
  1494.  
  1495. END(*CASE*);
  1496. END(*WITH MEMORY*);
  1497. END(*PINT1*);
  1498.  
  1499. PROCEDURE PINT;
  1500.     BEGIN
  1501.     IF INST<0 THEN MERR(READV);
  1502.     IF INST>40
  1503.     THEN PINT1(INST)
  1504.     ELSE PINT0(INST)
  1505.     END(*PINT*);
  1506.  
  1507.  
  1508. PROCEDURE INTERPRET;(*ORIGINAL ENTRY PLACED BEFORE ABORT*)
  1509.     BEGIN
  1510. WITH MEMORY DO BEGIN
  1511.     INSTR:=I;
  1512.     REPEAT
  1513.         IP:=IP+W;
  1514.         IF (*PRIMITIVE?*) INSTR<NUMINSTR
  1515.         THEN PINT(INSTR)
  1516.         ELSE    BEGIN
  1517.             IF (INSTR<RAMMIN)OR(INSTR>RAMMAX)
  1518.             THEN MERR(READV);
  1519.             RPUSH(IP);
  1520.             IP:=INSTR;
  1521.             END;
  1522.         INSTR:=RAM[IP];
  1523.         (*TRACE PATCH*)
  1524.         IF RPTR=(RAM[USR+W*15]-R*2)
  1525.         THEN    BEGIN
  1526.             SAVINSTR:=INSTR;
  1527.             SAVLEVEL:=RPTR;
  1528.             INSTR:=RAM[USR+W*22];
  1529.             IP:=IP-W;
  1530.             REPEAT
  1531.                 IP:=IP+W;
  1532.                 IF (*PRIMITIVE?*)
  1533.                     INSTR<NUMINSTR
  1534.                 THEN PINT(INSTR)
  1535.                 ELSE BEGIN
  1536.                     IF(INSTR<RAMMIN)OR(INSTR>RAMMAX)
  1537.                     THEN MERR(READV);
  1538.                     RPUSH(IP);
  1539.                     IP:=INSTR;
  1540.                     END;
  1541.                 INSTR:=RAM[IP];
  1542.             UNTIL RPTR<(SAVLEVEL+R);
  1543.             INSTR:=SAVINSTR;
  1544.             END(*TRACE PATCH*);
  1545.     UNTIL RPTR<RSTACKMIN;
  1546.     IP:=IP-W;(*RESTORE THE ORIGINAL IP TO ORIGINAL*)
  1547.  
  1548.     
  1549. END(*WITH MEMORY*);
  1550.     END(*PROCEDURE INTERPRET*);
  1551.  
  1552. PROCEDURE COMPLINE;
  1553. (* COMPILE AN INPUT LINE INTO THE COMPILE BUFFER*)
  1554. BEGIN
  1555. WITH MEMORY DO BEGIN
  1556. IF (RAM[USR+W*7]=FALS) OR (RAM[USR+W*9]<>FALS)
  1557.     THEN PROMPT;
  1558. IF (RAM[USR+W*7]>0) AND (RAM[USR+W*7]<MAXLINNO)
  1559. THEN    BEGIN
  1560.     PUSH(RAM[USR+W*7]);
  1561.     INTERPRET(RAM[USR+W*24]);
  1562.     RAM[USR+W*7]:=RAM[USR+W*7]+1;
  1563.     END(*THEN*)
  1564. ELSE
  1565.     GETLINE;
  1566. IGNRBLNKS;
  1567. WHILE STRINGS[RAM[USR+W*11]] <> CHR(NEWLINE) DO
  1568.     BEGIN
  1569.     RAM[USR+W*14] := RAM[USR+W*11]; (* NOTE TOKEN START*)
  1570.     INTOKEN;
  1571.     PUSH(RAM[USR+W*3]);
  1572.     FIND;
  1573.     ADDR:=POP;
  1574.     IF ADDR<>FALS
  1575.     THEN(*FOUND*) INTERPRET(ADDR-W) (* THE CPA *)
  1576.     ELSE
  1577.     BEGIN(*NOT DEFINED DURING EXECUTION*)
  1578.     IF(CONVERT(RAM[USR+W*3],RAM[USR+W*0],VAL))
  1579.     THEN    BEGIN
  1580.         COMPILE(LIT);
  1581.         COMPILE(VAL)
  1582.         END
  1583.     ELSE    IF STRINGS[RAM[USR+W*3]+1]='''' THEN
  1584.             BEGIN
  1585.             VAL:=SLIT;
  1586.             COMPILE(STRLIT);
  1587.             COMPILE(VAL);
  1588.             END(*IF SINGLE-QUOTED STRING*)
  1589.         ELSE IF STRINGS[RAM[USR+W*3]+1]='"' THEN
  1590.             BEGIN    LONGSTRING(VAL);
  1591.                 COMPILE(STRLIT);
  1592.                 COMPILE(VAL);
  1593.             END(*DOUBLE QUOTED STRING*)
  1594.  
  1595.         ELSE IF RAM[USR+W*33]<>FALS THEN INTERPRET(RAM[USR+W*33])
  1596.             (*USER SUPPLIED CONVERSION*)
  1597.  
  1598.         ELSE    BEGIN (*TOKEN NOT DECHIPHERABLE*)
  1599.             RAM[USR+W*10]:=TRU(*TURN ON CONSOLE*);
  1600.             (*SHOW BAD LINE IF NOT ON CONSOLE*)
  1601.             IF (RAM[USR+W*7]<>FALS) AND (RAM[USR+W*9]=FALS)
  1602.             THEN    BEGIN
  1603.                 (* IFCR *)
  1604.                 IF RAM[USR+W*20]>0
  1605.                 THEN CARRET;
  1606.                 MESSAGE(LINEBUF);
  1607.                 END(*IF*);
  1608.  
  1609.             MESSAGE(RAM[USR+W*3]);
  1610.             WRITELN(OUTPUT,' ?');
  1611.             IF RAM[USR+W*8]<>FALS THEN WRITELN(LIST,' ?');
  1612.             ABORT;
  1613.             END
  1614.     END(*NOT DEFINED DURING EXECUTION*);
  1615.     IGNRBLNKS;
  1616.     END(*WHILE*);
  1617.  
  1618. END(*WITH MEMORY*);
  1619. END(*PROCEDURE COMPLINE*);
  1620.  
  1621. PROCEDURE ADDSTRING(LENGTH:INTEGER; STRING:DALFA;VAR START:INTEGER);
  1622. (*CONVENIENCE DURING INITIALIZATION OF PISTOL*)
  1623. VAR I:INTEGER;
  1624. BEGIN(*ADDSTRING*)
  1625. WITH MEMORY DO BEGIN
  1626.     START:=RAM[USR+W*3];
  1627.     RAM[USR+W*3]:=RAM[USR+W*3]+1;
  1628.     FOR I:= 1 TO LENGTH  DO
  1629.         BEGIN
  1630.         STRINGS[RAM[USR+W*3]]:=STRING[I];
  1631.         RAM[USR+W*3]:=RAM[USR+W*3]+1;
  1632.         END(*FOR*);
  1633.  
  1634.     STRINGS[START]:=CHR(I-1);
  1635.     (* STRING HAS NOW BEEN PLACED IN STRINGS,RAM[USR+W*3]
  1636.         HAS BEEN UPDATED*)
  1637.     PERMSTRINGS;
  1638. END(*WITH MEMORY*);
  1639. END(*ADDSTRING*);
  1640.  
  1641. PROCEDURE PENTER(LENGTH:INTEGER;NAME:DALFA;OPCODE:INTEGER);
  1642. (* THIS PROCEDURE IS USED ONLY TO SIMPLIFY BRINGING UP
  1643.     PISTOL; THE PRIMITIVE,"BUILT-IN" FUNCTIONS ARE
  1644.     ENTERED INTO THE DICTIONARY BY THIS PROCEDURE.
  1645.     IF OPCODE IS POSITIVE, IT IS 'NOTIMMEDIATE',
  1646.     HENCE THE COMPILE-TIME OPCODE SHOULD BE 27, ELSE
  1647.     IF OPCODE IS NEGATIVE, IT IS IMMEDIATE*)
  1648.  
  1649. VAR START:INTEGER;
  1650.  
  1651. BEGIN(*PENTER*)
  1652. WITH MEMORY DO BEGIN
  1653.     ADDSTRING(LENGTH,NAME,START);
  1654.     APPEND(0);(*SPACE FOR ENDA*)
  1655.     APPEND(RAM[RAM[USR+W*5]]);    (*LINK FIELD*)
  1656.     APPEND(START);        (*NAME FIELD*)
  1657.  
  1658.     (*COMPILE-TIME FIELD: *)
  1659.     IF OPCODE<0
  1660.     THEN    BEGIN
  1661.         APPEND(-OPCODE)    (*IMMEDIATE WORD*);
  1662.         APPEND(PSEMICOLON)    (*FOR SYMMETRY*)
  1663.         END
  1664.  
  1665.     ELSE    BEGIN
  1666.         APPEND(COMPME);    (*PRIMITIVE NOTIMMEDIATE*)
  1667.         APPEND(OPCODE);
  1668.         END(*ELSE*);
  1669.  
  1670.     RAM[RAM[USR+W*5]]:=RAM[USR+W*2]-W;    (*UPDATE CURRENT*)
  1671.     PUSH(RAM[USR+W*2]);
  1672.     FENTER;(* ENDA:=.D *)
  1673. END(*WITH MEMORY*);
  1674. END(*PENTER*);
  1675.  
  1676. PROCEDURE INIT;(*USED ONLY TO INITIALIZE CONSTANTS AND
  1677.         VARIABLES*)
  1678. BEGIN(*INIT*)
  1679. WITH MEMORY DO BEGIN
  1680. FOR TEMP:=RAMMIN TO RAMMAX DO RAM[TEMP]:=10000;
  1681. REWRITE(OUTPUT,'TTY:      ');
  1682. FOR I:=1 TO 20 DO NULLNAME[I]:=CHR(0);
  1683. LISTNAME:=NULLNAME;
  1684. STKPTR:=STACKMIN;
  1685. RAM[USR-W*21]:=-1-MAXINT;(*MININT,MACHINE DEPENDENT*)
  1686. RAM[USR-W*20]:=MAXLINNO;
  1687. RAM[USR-W*19]:=CHKLMT;(*SIZE OF SYNTAX CHECKSTACK*)
  1688. RAM[USR-W*18]:=RAMMIN;
  1689. RAM[USR-W*17]:=STRINGSMIN;
  1690.  
  1691. RAM[USR+W*34]:=FALS;(*ABORT PATCH*)
  1692. RAM[USR+W*33]:=FALS;(*CONVERSION PATCH*)
  1693. RAM[USR+W*32]:=FALS;(*STANDARD PROMPT*)
  1694. RAM[USR-W*16]:=STRINGSMAX;
  1695. RAM[USR-W*15]:=VBASE;
  1696. RAM[USR-W*14]:=VSIZE;
  1697. RAM[USR-W*13]:=CSIZE;
  1698. RAM[USR-W*12]:=LSIZE;
  1699. RAM[USR-W*11]:=RSIZE;
  1700. RAM[USR-W*10]:=SSIZE;
  1701. RAM[USR-W*9]:=LINEBUF;
  1702. RAM[USR-W*8]:=COMPBUF;
  1703. RAM[USR-W*7]:=RAMMAX;
  1704. RAM[USR-W*6]:=MAXORD;
  1705. RAM[USR-W*5]:=MAXINT;
  1706. RAM[USR-W*4]:=VERSION;
  1707. RAM[USR-W*3]:=NEWLINE;
  1708. RAM[USR-W*2]:=TRU;(*READ_PROTECT*)
  1709. RAM[USR-W*1]:=TRU;(*WRITE_PROTECT*)
  1710. RAM[USR+W*29]:=0;
  1711. RAM[USR+W*30]:=FALS;(* PISTOL< LINK IS NIL;
  1712.             IT'S AT THE END OF BRANCH LIST*)
  1713.     (*INITIALIZE FILE STATUS*)
  1714. RAM[USR+W*27]:=+1;(*EDOUT*)
  1715. RAM[USR+W*26]:=-1;(*EDIN*)
  1716. RAM[USR+W*25]:=-1;(*LDFIL*)
  1717. RAM[USR+W*23]:=8; (*INITIALIZE TABSIZE*)
  1718. RAM[USR+W*21]:=ABRT; (*INITIALIZE ENDCASE TO ABORT*)
  1719. RAM[USR+W*19]:=64 (* INITIALIZE TERMINAL WIDTH*);
  1720. RAM[USR+W*17]:=20 (* INITIALIZE TERMINAL PAGE LENGTH*);
  1721. RAM[USR+W*16]:=FALS;(*COMPILE-END-PATCH*)
  1722. RAM[USR+W*15]:=FALS;(*INITALIZE TRACE OFF*)
  1723. RAM[USR+W*13]:=TRU (*RAISE ON*);
  1724. RAM[USR+W*9]:=FALS (*ECHO OFF*);
  1725. RAM[USR+W*8]:=FALS;(*LIST OFF*)
  1726. RAM[USR+W*5]:=USR+W*29;
  1727. RAM[USR+W*2]:=MAX(NUMINSTR+1,USR+W*(45+VSIZE+RSIZE) );
  1728. (*SET BASE OF DICTIONARY*)
  1729. RAM[USR+W*4]:=SYNTAXBASE+CHKLMT+1;
  1730. RAM[USR+W*3]:=RAM[USR+W*4];
  1731. ADDSTRING(18,'**READ VIOLATION**  ',READV);
  1732. ADDSTRING(20,'**WRITE VIOLATION** ',WRITV);
  1733. ADDSTRING(20,'*** EOF ENCOUNTERED*',FEOF);
  1734. ADDSTRING(20,'*** FILE NOT OPENED*',NOPEN);
  1735. ADDSTRING(18,'*** PISTOL 2.0 ***  ',ID);
  1736. ADDSTRING(20,'*** SYNTAX ERROR ***',SYNT);
  1737. ADDSTRING(19,'** STACK OVERFLOW **',OVFLO);
  1738. ADDSTRING(19,'* STACK UNDERFLOW * ',UNDFLO);
  1739. ADDSTRING(16,'---REDEFINING---    ',REDEF);
  1740. ADDSTRING(16,'DIVISION BY ZERO    ',DIVBY0);
  1741. PENTER(2,'W!                  ',WSTORE);
  1742. PENTER(1,'*                   ',TIMES);
  1743. PENTER(1,'+                   ',PLUS);
  1744. PENTER(1,'-                   ',SUBTRACT);
  1745. PENTER(4,'/MOD                ',DIVMOD);
  1746. PENTER(2,'W@                  ',WAT);
  1747. PENTER(5,'ABORT               ',ABRT);
  1748. PENTER(2,'SP                  ',SP);
  1749. PENTER(4,'LOAD                ',LOAD);
  1750. PENTER(1,'W                   ',WRD);
  1751. PENTER(2,'RP                  ',RP);
  1752. PENTER(4,'DROP                ',DROPOP);
  1753. PENTER(4,'USER                ',PUSER);
  1754. PENTER(4,'EXEC                ',EXEC);
  1755. PENTER(4,'EXIT                ',EXITOP);
  1756. PENTER(2,'R>                  ',RPOP);
  1757. PENTER(4,'SWAP                ',SWP);
  1758. PENTER(3,'TYI                 ',TYI);
  1759. PENTER(3,'TYO                 ',TYO);
  1760. PENTER(2,'<R                  ',RPSH);
  1761. PENTER(2,';F                  ',SEMICF);
  1762. PENTER(2,'R@                  ',RAT);
  1763. PENTER(2,'$:                  ',-DOLLARC);
  1764. PENTER(1,':                   ',-COLON);
  1765. PENTER(1,';                   ',-SEMICOLON);
  1766. PENTER(2,'IF                  ',-IFOP);
  1767. PENTER(4,'ELSE                ',-ELSEOP);
  1768. PENTER(4,'THEN                ',-THENOP);
  1769. PENTER(2,'DO                  ',-DOOP);
  1770. PENTER(4,'LOOP                ',-LOOPOP);
  1771. PENTER(5,'BEGIN               ',-BEGINOP);
  1772. PENTER(3,'END                 ',-ENDOP);
  1773. PENTER(6,'REPEAT              ',-REPET);
  1774. PENTER(1,'%                   ',-PERCENT);
  1775. PENTER(5,'CASE@               ',CASAT);
  1776. PENTER(5,'+LOOP               ',-PLLOOP);
  1777. PENTER(2,'C@                  ',CAT);
  1778. PENTER(2,'C!                  ',CSTORE);
  1779. PENTER(2,'..                  ',DOTDOT);
  1780. PENTER(2,';$                  ',-SEMIDOL);
  1781. PENTER(10,'PRIMITIVE?          ',PRMQ);
  1782. PENTER(2,'S@                  ',SAT);
  1783. PENTER(4,'FIND                ',FINDOP);
  1784. PENTER(8,'LISTFILE            ',LISTFIL);
  1785. PENTER(5,'VFIND               ',VFINDOP);
  1786. PENTER(2,'L@                  ',LAT);
  1787. PENTER(6,'OFCASE              ',-OFCAS);
  1788. PENTER(2,'C:                  ',-CCOLON);
  1789. PENTER(2,';C                  ',-SEMICC);
  1790. PENTER(7,'ENDCASE             ',-NDCAS);
  1791. PENTER(4,'(;C)                ',PSEMICC);
  1792. PENTER(7,'GETLINE             ',GTLIN);
  1793. PENTER(4,'WORD                ',WORD);
  1794. PENTER(5,'OPENR               ',OPENR);
  1795. PENTER(5,'OPENW               ',OPENW);
  1796. PENTER(8,'READLINE            ',READL);
  1797. PENTER(9,'WRITELINE           ',WRITL);
  1798. PENTER(8,'COREDUMP            ',CORDMP);
  1799. PENTER(7,'RESTORE             ',RESTOR);
  1800.  
  1801.  
  1802.  
  1803. RAM[USR+W*0]:=10;    (*DECIMAL MODE*)
  1804. STRINGS[STRINGSMIN] := 'X';
  1805. STRINGS[SYNTAXBASE]:=CHR(0);
  1806. END(*WITH MEMORY*);
  1807. END(*INIT*);
  1808.  
  1809.  
  1810. (******************************************)
  1811. BEGIN(*PISTOL MAIN*)
  1812. WITH MEMORY DO BEGIN    INIT;
  1813. ABORT;
  1814. REPEAT
  1815. RAM[USR+W*1]:=COMPBUF;
  1816. REPEAT
  1817. COMPLINE;
  1818. UNTIL STRINGS[SYNTAXBASE]=CHR(0);
  1819. COMPILE(PSEMICOLON);
  1820.  
  1821. IF RAM[USR+W*16]<>FALS THEN INTERPRET(RAM[USR+W*16]);
  1822.  
  1823. IF (RAM[USR+W*10]<>FALS) AND ((RAM[USR+W*7]=FALS) OR (RAM[USR+W*9]<>FALS))
  1824. THEN    BEGIN
  1825.     RAM[USR+W*20]:=FALS (*RESET COLUMN POSTION VARIABLE*);
  1826.     RAM[USR+W*18]:= 0 (*RESET TERMINAL LINE COUNT*);
  1827.     END;
  1828. INTERPRET(COMPBUF);
  1829. 99:
  1830.  
  1831. RAM[USR+W*3]:=RAM[USR+W*4];
  1832. UNTIL RAM[USR+W*31]<>FALS(*SESSION DONE*);
  1833.  
  1834. WRITELN(OUTPUT,'PISTOL NORMAL EXIT');
  1835. IF RAM[USR+W*8]<>FALS THEN WRITELN(LIST,'PISTOL NORMAL EXIT');
  1836. (*FLUSH AND CLOSE FILES IF OPERATING SYSTEM DOESN'T DO IT*)
  1837. END(*WITH MEMORY*);
  1838. END.
  1839.