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