YaK:: TRS-80 Tiny Pascal Compiler Source ( PASCAL COMPILER V2 12/11/78 V.TRS-80 3/02/79 ) [Changes]   [Calendar]   [Search]   [Index]   [PhotoTags]   
[mega_changes]
[photos]

TRS-80 Tiny Pascal Compiler Source ( PASCAL COMPILER V2 12/11/78 V.TRS-80 3/02/79 )

Back around 1980 I had a TRS-80 model I computer. I got the Tiny Pascal language cassette from Radio Shack. On the front side of the cassette, it had the runtime that you needed to compile and exectute programs. As a bonus, on the back side it had the source code to Tiny Pascal, written in Tiny Pascal.

I taught myself how to write a compiler by studying this code.

I also hand-disassembled the P-Code interpreter and learned about bytecode engines from it.

Today I was able to rip this file out of a DMK file (posted at the bottom) using some Go code (also posted at the bottom) and then some hand-editing.

-- strick 31jan2020



(* PASCAL COMPILER  V2  12/11/78   V.TRS-80  3/02/79 *)
 (* LAST MOD 5/05/79 *)
CONST ALHF=2; (*ID LEN=4*)
                RAL=6; RAL1=5;
        SYCB=%4180; (*SYSTEM CONTROL BLOCK*)
  NRWD=29; (*# OF RES. WDS*)
  XAND         =128; XARRAY  =129; XBEGIN  =130; XCASE  =131;
  XCONST  =132; XDIV         =133; XDO          =134; XDOWNTO =135; XELSE        =136;
  XEND         =137; XFOR         =138; XFUNC        =139; XIF          =140;
  XINTEGER=141; XMOD         =142; XNOT         =143; XOF          =144;
  XOR          =145; XPROC        =146; XREAD        =147; XREPEAT =148;
  XSHL         =149; XSHR         =150; XTHEN        =151; XTO          =152;
  XUNTIL  =153; XVAR         =154; XWHILE  =155; XWRITE  =156;
  IDENT        =180; NUMBER  =181; STRING  =182;
  BECOMES =190; EQ                =192; NEQ          =194; LT                =196; GEQ          =198;
  GT                =200; LEQ          =202;
  TCONST=0; TINT=1; TARRAY=2; TPROC=3; TFUNC=4; TPAR=5; TFVAL=6; (*TYPE*)
  LIT=0;LOD=2;LODX=6;STO=10;STOX=14;CAL=18;INT=22;JMP=24;JPC0=26;
  JPC1=28;LIT0=30;INCT=42;DECT=44;RET0=46;NEG0=48;ADD0=50;
  SUB0=52;MUL0=54;DIV0=56;ODD0=58;MOD0=60;EQU0=62;NEQ0=64;
  LT0 =66;GEQ0=68;GT0 =70;LEQ0=72;OR0 =74;AND0=76;NOT0=78;
  SHL0=80;SHR0=82;INC0=84;DEC0=86;CPY0=88;INCH=90;OUTCH=92;
  INNUM=94;OUTNUM=96;INHEX=98;OUTHEX=100;OUTSTR=102;
VAR CH, (*LAST CHAR READ*)
  SYM, (*LAST SYMBOL READ*)
  NUM, (* LAST NUMBER RED*)
  SL, (*STR LEN*)
  RDPTR, (*READ FILE PTR*)
  RWDTBL, (*RES. WD TABLE*)
  TBLINDX, (*SYM TABLE INDEX*)
  GENP, (*FLAG TO GEN CODES*)
  MADDR,KADDR,(*MEM ADDR FOR P-CODES*)
         I:INTEGER;
  ID (*LAST IDENTIFIER READ*): ARRAY (RAL1) OF INTEGER;
  IDP (*ID PACKED*): ARRAY(ALHF) OF INTEGER;
  STR: ARRAY(63) OF INTEGER;
  SYMID: ARRAY(400) OF INTEGER;
  SYMTYPE,SYMNPAR,SYMVAL,SYMLVL: ARRAY(200) OF INTEGER;
  ALPHA: ARRAY(127) OF INTEGER;

PROC INIT;
  VAR PADDR:INTEGER;
BEGIN RDPTR:=MEMW(SYCB)-1;
  MADDR:=MEMW(SYCB+4); KADDR:=MADDR;
  GENP:=MEM(SYCB+5)<>0 (*SET GEN CODE FLAG*);
        RWDTBL:=MEMW(SYCB+10)-%0120; (*ADDR OF COMPC - 18 REC*)
        TBLINDX:=0; PADDR:=RWDTBL+176; (*PREDEFINED PROC TABLE*)
        WHILE MEM(PADDR)<>0 DO BEGIN
                TBLINDX:=TBLINDX+1;
                SYMID(TBLINDX*2):=MEMW(PADDR);
                SYMID(TBLINDX*2+1):=MEMW(PADDR+2);
                SYMTYPE(TBLINDX):=MEM(PADDR+4);
                SYMLVL(TBLINDX):=-1;
                SYMNPAR(TBLINDX):=MEM(PADDR+5);
                SYMVAL(TBLINDX):=MEM(PADDR+7);
                PADDR:=PADDR+8 END
END;

PROC GETSYM;
  VAR I,J,K,L,M,DONE:INTEGER;
  PROC GETCH;
  BEGIN RDPTR:=RDPTR+1; CH:=MEM(RDPTR); WRITE(CH);
         IF CH<' ' THEN CH:=' '
         END;

  FUNC HEX(X);
  BEGIN IF X<'A' THEN HEX:=X-'0' ELSE HEX:=X-'A'+10 END;

  PROC PACKID;
         VAR I:INTEGER;
  BEGIN
         IDP(0):=ID(0)+ID(1)SHL 8;
        IDP(1):=ID(2)+ID(3)SHL 8
         END;

BEGIN (*GETSYM*)
  WHILE CH=' ' DO GETCH;
  IF ALPHA(CH) THEN
  BEGIN (*ID OR RES WDS*) K:=0;
         REPEAT IF K<RAL THEN BEGIN ID(K):=CH;K:=K+1 END; GETCH
         UNTIL ALPHA(CH)=0;
         FOR I:=K TO RAL1 DO ID(I):=' ';
         (*BIN SEARCH FOR KEY WORDS*)
         I:=0; J:=NRWD-1;
         REPEAT K:=(I+J)SHR 1; M:=K*RAL+RWDTBL; L:=-1;
                REPEAT L:=L+1 UNTIL (ID(L)<>MEM(M+L)) OR (L>=RAL);
                IF ID(L)<MEM(M+L) THEN J:=K-1 ELSE I:=K+1
         UNTIL (I>J) OR (L>=RAL);
         IF L>=RAL THEN SYM:=128+K
         ELSE BEGIN SYM:=IDENT; PACKID END END
  ELSE IF ALPHA(CH)=2 THEN
  BEGIN (*NUMBER*) NUM:=0; SYM:=NUMBER;
         REPEAT NUM:=10*NUM+CH-'0'; GETCH
         UNTIL ALPHA(CH)<>2 END
  ELSE CASE CH OF (*SPECIAL 2 CHAR SYMBOLS*)
         ':':BEGIN GETCH; IF CH='=' THEN
                         BEGIN SYM:=BECOMES; GETCH END
                         ELSE SYM:=':' END;
         '<':BEGIN GETCH; CASE CH OF
                  '=':BEGIN SYM:=LEQ; GETCH END;
                  '>':BEGIN SYM:=NEQ; GETCH END
                  ELSE SYM:=LT END END;
         '>':BEGIN GETCH; IF CH='=' THEN
                         BEGIN SYM:=GEQ; GETCH END
                         ELSE SYM:=GT END;
         '=':BEGIN SYM:=EQ; GETCH END;
         39(*'*):BEGIN SYM:=STRING; SL:=0; GETCH;
                                WHILE CH<>39 DO BEGIN STR(SL):=CH; SL:=SL+1; GETCH END;
                                NUM:=STR(0); GETCH END;
         '(':BEGIN GETCH;
                IF CH='*' THEN BEGIN DONE:=0; GETCH;
                  REPEAT WHILE CH<>'*' DO GETCH;
                         GETCH; IF CH=')' THEN DONE:=1
                  UNTIL DONE;
                  GETCH; GETSYM END
                ELSE SYM:='(' END;
         '%':BEGIN (*HEX CONST*) GETCH;
                         NUM:=0; SYM:=NUMBER; I:=0;
                         WHILE (ALPHA(CH)=2) OR (CH>='A') AND (CH<='F') DO
                         BEGIN NUM:=NUM SHL 4+HEX(CH); GETCH; I:=I+1 END;
                                IF I=0 THEN SYM:='%' END
         ELSE BEGIN SYM:=CH; GETCH END
         END (*CASE*)
  END (*GETSYM*);

PROC ERROR(ERRNUM);
BEGIN WRITE(08,'<ERROR ',ERRNUM#);
        CALL(MEMW(SYCB+20)) END;

PROC BLOCK(LEVEL,BADDR);
  VAR I,T,KIND,DONE,TADDR,NVAR:INTEGER;

PROC GEN3(OPCODE);
BEGIN IF GENP THEN BEGIN
        MEM(MADDR):=OPCODE; MADDR:=MADDR+1 END END;

PROC GEN1(OPCODE,I);
  VAR LEV,J:INTEGER;
BEGIN IF GENP THEN BEGIN J:=SYMVAL(I);
        IF SYMLVL(I)<0 THEN (*PREDEFINED PROC*)
                IF OPCODE=STOX THEN GEN3(J+4) ELSE GEN3(J)
        ELSE BEGIN
         IF OPCODE<>CAL THEN J:=J+16; (* OFFSET BY 16 *)
         LEV:=LEVEL-SYMLVL(I);
         IF LEV>7 THEN ERROR(250);
         IF LEV<>0 THEN OPCODE:=OPCODE+2;
         MEM(MADDR):=OPCODE;
         MEM(MADDR+1):=J;
         MEM(MADDR+2):=(LEV SHL 5) OR (J AND %1F00 SHR 8);
         MADDR:=MADDR+3 END END END;

PROC GEN2(OPCODE,NUM);
BEGIN IF GENP THEN
  IF (OPCODE=LIT) AND (NUM=0) THEN GEN3(LIT0)
  ELSE BEGIN
  MEM(MADDR):=OPCODE;
  MEMW(MADDR+1):=NUM;
  MADDR:=MADDR+3 END END;

  PROC ENTER(TYP);
         VAR I,J:INTEGER;
  BEGIN TBLINDX:=TBLINDX+1;
         I:=TBLINDX*ALHF;
         SYMID(I):=IDP(0); SYMID(I+1):=IDP(1);
         SYMTYPE(TBLINDX):=TYP;
         CASE TYP OF
                TCONST: SYMVAL(TBLINDX):=NUM;
                TINT: BEGIN SYMLVL(TBLINDX):=LEVEL;
                                SYMVAL(TBLINDX):=NVAR; NVAR:=NVAR+1 END;
                TPAR: BEGIN SYMTYPE(TBLINDX):=TINT; SYMLVL(TBLINDX):=LEVEL+1 END;
                TPROC,TFUNC: BEGIN SYMLVL(TBLINDX):=LEVEL;
                  SYMVAL(TBLINDX):=MADDR-KADDR END;
                TFVAL:SYMLVL(TBLINDX):=LEVEL+1
         END
         END; (*ENTER*)

  FUNC POSITION;
         VAR I:INTEGER;
  BEGIN SYMID(0):=IDP(0); SYMID(1):=IDP(1);
         I:=TBLINDX*ALHF+ALHF;
         REPEAT I:=I-2
         UNTIL (SYMID(I)=IDP(0)) AND (SYMID(I+1)=IDP(1));
         POSITION:=I SHR 1;
         IF I=0 THEN ERROR(104)
         END; (*POSITION*)

  PROC CHKSYM(SYMBOL,ERRNUM);
  BEGIN IF SYM<>SYMBOL THEN ERROR(ERRNUM);
         GETSYM
  END;

  PROC PROCPAR(TTYPE);
         VAR I,K:INTEGER;
  BEGIN IF TTYPE=TFUNC THEN ENTER(TFVAL);
         IF SYM=';' THEN BEGIN GETSYM;
                IF TTYPE=TFUNC THEN BEGIN
                  SYMNPAR(TBLINDX-1):=0; SYMVAL(TBLINDX):=-1 END
                ELSE SYMNPAR(TBLINDX):=0 END
         ELSE BEGIN
         IF SYM<>'(' THEN ERROR(9); K:=0;
         REPEAT GETSYM; K:=K+1;
                IF SYM=IDENT THEN ENTER(TPAR) ELSE ERROR(2);
                GETSYM
         UNTIL SYM<>',';
         SYMNPAR(TBLINDX-K-(TTYPE=TFUNC)):=K;
         FOR I:=-K TO -1 DO SYMVAL(TBLINDX+I+1):=I;
         IF TTYPE=TFUNC THEN SYMVAL(TBLINDX-K):=-K-1;
         CHKSYM(')',4); CHKSYM(';',14) END
  END;

  PROC PCONST;
         VAR I,NEG:INTEGER;
  BEGIN
         IF SYM<>STRING THEN BEGIN NEG:=0;
                CASE SYM OF
                  '+':GETSYM;
                  '-':BEGIN NEG:=1; GETSYM END
                END;
                CASE SYM OF
                  IDENT:BEGIN I:=POSITION;
                         IF SYMTYPE(I)=TCONST THEN
                                NUM:=SYMVAL(I) ELSE ERROR(50) END;
                  NUMBER:
                ELSE ERROR(50) END;
                IF NEG THEN NUM:=-NUM
         END;
         GETSYM
  END;

  PROC FIXUP(ADDR,CADDR);
  BEGIN IF GENP THEN MEMW(ADDR+1):=CADDR-KADDR END;

  PROC STATEMENT;
         VAR I,K,TADDR,T2ADDR,TVALUE,TLEVEL:INTEGER;
         PROC EXPRESSION;
                VAR OP:INTEGER;
                PROC SIMPEXP;
                  VAR OP:INTEGER;
                  PROC TERM;
                         VAR OP:INTEGER;
                         PROC FACTOR;
                                VAR I,K:INTEGER;
                         BEGIN CASE SYM OF
                                IDENT:BEGIN I:=POSITION; GETSYM;
                                  CASE SYMTYPE(I) OF
                                         TCONST:GEN2(LIT,SYMVAL(I));
                                         TINT:GEN1(LOD,I);
                                         TFUNC,TFVAL:BEGIN GEN3(INCT);
                                                IF SYMTYPE(I)=TFVAL THEN (*RECURSIVE CALL*) I:=I-1;
                                                IF SYMNPAR(I)=0 THEN GEN1(CAL,I)
                                                ELSE BEGIN K:=0;
                                                  IF SYM<>'(' THEN ERROR(9);
                                                  REPEAT GETSYM; EXPRESSION; K:=K+1 UNTIL SYM<>',';
                                                  IF K<>SYMNPAR(I) THEN ERROR(126); CHKSYM(')',4);
                                                  GEN1(CAL,I); GEN2(INT,-K) END
                                                END;
                                         TARRAY:BEGIN CHKSYM('(',11);
                                                EXPRESSION ;CHKSYM(')',12);
                                                GEN1(LODX,I) END
                                         ELSE ERROR(58)
                                         END
                                  END;
                                STRING,NUMBER:BEGIN GEN2(LIT,NUM); GETSYM END;
                                '(':BEGIN GETSYM;
                                  EXPRESSION; CHKSYM(')',4) END;
                                XNOT:BEGIN GETSYM; FACTOR; GEN3(NOT0) END
                                ELSE ERROR(58)
                         END END; (*FACTOR*)

                  BEGIN (*TERM*)
                         FACTOR;
                         WHILE (SYM='*') OR (SYM=XDIV) OR (SYM=XAND) OR (SYM=XMOD)
                                OR (SYM=XSHL) OR (SYM=XSHR) DO
                         BEGIN OP:=SYM; GETSYM; FACTOR;
                                CASE OP OF
                                '*' :GEN3(MUL0);
                                XDIV:GEN3(DIV0);
                                XAND:GEN3(AND0);
                                XMOD:GEN3(MOD0);
                                XSHL:GEN3(SHL0);
                                XSHR:GEN3(SHR0) END
                         END
                  END;

                BEGIN (*SIMPEXP*)
                  IF (SYM='+') OR (SYM='-') THEN BEGIN
                         OP:=SYM; GETSYM; TERM;
                         IF OP='-' THEN GEN3(NEG0) END
                  ELSE TERM;
                  WHILE (SYM='+') OR (SYM='-') OR (SYM=XOR) DO
                  BEGIN OP:=SYM; GETSYM; TERM;
                         CASE OP OF
                         '+':GEN3(ADD0);
                         '-':GEN3(SUB0);
                         XOR:GEN3(OR0) END
                  END
                END;

         BEGIN (*EXPRESSION*)
                SIMPEXP;
                IF (SYM>=EQ) AND (SYM<=LEQ) THEN
                  BEGIN OP:=SYM; GETSYM; SIMPEXP; GEN3(OP-EQ+EQU0) END
         END;

         PROC CASELBL;
                VAR TADDR,T2ADDR:INTEGER;
                PROC SUBLBL;
                  VAR TADDR:INTEGER;
                BEGIN PCONST;
                  GEN3(CPY0);GEN2(LIT,NUM);GEN3(EQU0);
                  IF SYM=',' THEN BEGIN
                         TADDR:=MADDR; GEN2(JPC1,0);
                         GETSYM; SUBLBL;
                         FIXUP(TADDR,MADDR+3) END
                END;
         BEGIN SUBLBL; CHKSYM(':',14);
                TADDR:=MADDR; GEN2(JPC0,0);
                STATEMENT;
                CASE SYM OF
                ';': BEGIN T2ADDR:=MADDR; GEN2(JMP,0);
                         FIXUP(TADDR,MADDR);
                         GETSYM; CASELBL;
                         FIXUP(T2ADDR,MADDR) END;
                XELSE: BEGIN T2ADDR:=MADDR; GEN2(JMP,0);
                         FIXUP(TADDR,MADDR);
                         GETSYM; STATEMENT;
                         CHKSYM(XEND,13);
                         FIXUP(T2ADDR,MADDR) END;
                XEND: BEGIN FIXUP(TADDR,MADDR); GETSYM END
                ELSE ERROR(13) END
         END;

         BEGIN (*STATEMENT*)
         CASE SYM OF
                IDENT:BEGIN I:=POSITION;
                  GETSYM; CASE SYMTYPE(I) OF
                         TINT,TFVAL:BEGIN
                                CHKSYM(BECOMES,51); EXPRESSION;
                                GEN1(STO,I) END;
                         TARRAY:BEGIN CHKSYM('(',11);
                                EXPRESSION;CHKSYM(')',12);
                                CHKSYM(BECOMES,51); EXPRESSION;
                                GEN1(STOX,I) END;
                         TPROC: BEGIN
                                IF SYMNPAR(I)=0 THEN GEN1(CAL,I)
                         ELSE BEGIN K:=0;
                                  IF SYM<>'(' THEN ERROR(9);
                                  REPEAT GETSYM; EXPRESSION; K:=K+1 UNTIL SYM<>',';
                                  IF K<>SYMNPAR(I) THEN ERROR(126); CHKSYM(')',4);
                                  GEN1(CAL,I);
                                  GEN2(INT,-K) END
                                END
                         ELSE ERROR(59) END
                  END;
                XBEGIN:BEGIN
                  REPEAT GETSYM; STATEMENT;
                  UNTIL SYM<>';';
                  CHKSYM(XEND,13)
                END;
                XIF:BEGIN GETSYM;EXPRESSION;
                  CHKSYM(XTHEN,52);
                  TADDR:=MADDR; GEN2(JPC0,0);
                  STATEMENT;
                  IF SYM=XELSE THEN BEGIN
                         T2ADDR:=MADDR;GEN2(JMP,0);
                         FIXUP(TADDR,MADDR);
                         GETSYM; STATEMENT;
                         FIXUP(T2ADDR,MADDR) END
                  ELSE FIXUP(TADDR,MADDR)
                END;
                XCASE:BEGIN GETSYM; EXPRESSION;
                  IF SYM<>XOF THEN ERROR(8); GETSYM;
                  CASELBL; GEN3(DECT) END;
                XWHILE:BEGIN TADDR:=MADDR-KADDR;
                  GETSYM; EXPRESSION;
                  T2ADDR:=MADDR; GEN2(JPC0,0);
                  CHKSYM(XDO,54);STATEMENT;
                  GEN2(JMP,TADDR); FIXUP(T2ADDR,MADDR)
                END;
                XREPEAT:BEGIN TADDR:=MADDR-KADDR;
                  REPEAT GETSYM; STATEMENT
                  UNTIL SYM<>';';
                  CHKSYM(XUNTIL,53);
                  EXPRESSION;
                  GEN2(JPC0,TADDR)
                END;
                XFOR:BEGIN GETSYM;
                  IF SYM<>IDENT THEN ERROR(2);
                  I:=POSITION;
                  IF SYMTYPE(I)<>TINT THEN ERROR(143);
                  GETSYM;CHKSYM(BECOMES,51);
                  EXPRESSION;
                  GEN1(STO,I);
                  CASE SYM OF
                         XTO: TVALUE:=INC0;
                         XDOWNTO: TVALUE:=DEC0
                         ELSE ERROR(55) END;
                  GETSYM; EXPRESSION;
                  TADDR:=MADDR-KADDR; GEN3(CPY0);
                  GEN1(LOD,I);
                  IF TVALUE=INC0 THEN GEN3(GEQ0) ELSE GEN3(LEQ0);
                  T2ADDR:=MADDR; GEN2(JPC0,0);
                  CHKSYM(XDO,54); STATEMENT;
                  GEN1(LOD,I); GEN3(TVALUE);
                  GEN1(STO,I); GEN2(JMP,TADDR);
                  FIXUP(T2ADDR,MADDR); GEN3(DECT)
                END;
                XWRITE:BEGIN GETSYM;
                  IF SYM<>'(' THEN ERROR(9);
                  REPEAT GETSYM;
                         IF SYM=STRING THEN BEGIN
                                GEN3(OUTSTR);
                                FOR I:=0 TO SL-1 DO GEN3(STR(I));
                                GEN3(0); (*END OF STR *)
                                GETSYM END
                         ELSE BEGIN EXPRESSION;
                                CASE SYM OF
                                  '#': BEGIN GEN3(OUTNUM); GETSYM END;
                                  '%': BEGIN GEN3(OUTHEX); GETSYM END
                                  ELSE GEN3(OUTCH) END
                         END
                  UNTIL SYM<>',';
                  CHKSYM(')',4)
                END;
                XREAD:BEGIN GETSYM;
                  IF SYM<>'(' THEN ERROR(9);
                  REPEAT GETSYM; IF SYM<>IDENT THEN ERROR(2);
                         I:=POSITION; GETSYM;
                         CASE SYMTYPE(I) OF
                                TINT:TVALUE:=STO;
                                TARRAY:BEGIN TVALUE:=STOX; CHKSYM('(',11);
                                  EXPRESSION;CHKSYM(')',12) END
                                ELSE ERROR(153) END;
                         CASE SYM OF
                                '#': BEGIN GEN3(INNUM); GETSYM END;
                                '%': BEGIN GEN3(INHEX); GETSYM END
                                ELSE GEN3(INCH) END;
                         GEN1(TVALUE,I)
                  UNTIL SYM<>',';
                  CHKSYM(')',4)
                END
         END
  END;

  BEGIN (*BLOCK*) NVAR:=3;
         TADDR:=MADDR; GEN2(JMP,0);
         IF SYM=XCONST THEN BEGIN
                GETSYM; IF SYM<>IDENT THEN ERROR(2);
                REPEAT
                  GETSYM; CHKSYM(EQ,16);
                  PCONST; ENTER(TCONST);
                  CHKSYM(';',14)
                UNTIL SYM<>IDENT END;
         IF SYM=XVAR THEN BEGIN
                GETSYM;
                REPEAT T:=TBLINDX; DONE:=0;
                  REPEAT IF SYM=IDENT THEN ENTER(TINT) ELSE ERROR(2);
                         GETSYM; IF SYM=',' THEN GETSYM ELSE DONE:=1
                  UNTIL DONE;
                  CHKSYM(':',5);
                  IF SYM=XARRAY THEN BEGIN
                         GETSYM; CHKSYM('(',11);
                         PCONST; CHKSYM(')',12); CHKSYM(XOF,8);
                         NVAR:=NVAR-TBLINDX+T;
                         FOR I:=T+1 TO TBLINDX DO BEGIN
                                SYMTYPE(I):=TARRAY;
                                SYMNPAR(I):=NUM;
                                SYMVAL(I):=NVAR;
                                NVAR:=NVAR+NUM+1 END END;
                  CHKSYM(XINTEGER,1);
                  CHKSYM(';',14)
                UNTIL SYM<>IDENT END;
         WHILE (SYM=XPROC) OR (SYM=XFUNC) DO BEGIN
                IF SYM=XPROC THEN KIND:=TPROC ELSE KIND:=TFUNC;
                GETSYM; IF SYM=IDENT THEN ENTER(KIND) ELSE ERROR(2);
                T:=TBLINDX; GETSYM; PROCPAR(KIND);
                BLOCK(LEVEL+1,T); TBLINDX:=T;
                CHKSYM(';',2) END;
         IF SYM=XBEGIN THEN BEGIN
                FIXUP(TADDR,MADDR);
                SYMVAL(BADDR):=MADDR-KADDR;
                GEN2(INT,NVAR);
                REPEAT GETSYM; STATEMENT
                UNTIL SYM<>';';
                CHKSYM(XEND,14); GEN3(RET0) END
         ELSE ERROR(18)
  END (*BLOCK*);
BEGIN INIT;
  FOR I:= 0  TO 127 DO ALPHA(I):=0;
  FOR I:='A' TO 'Z' DO ALPHA(I):=1;
  FOR I:='0' TO '9' DO ALPHA(I):=2;
  CH:=' '; GETSYM;
  BLOCK(0,0);
  IF SYM<>'.' THEN ERROR(1000);
  MEM(MADDR):=255;
  MEMW(SYCB+6):=MADDR;
        IF GENP THEN WRITE(MADDR-KADDR+1#,' CODES. ',
                KADDR%,'-',MADDR%)
END.


* * * N O T I C E * * *
* PROPRIETARY PROGRAM *
* COPYRIGHT (@) 1979  *
* BY TANDY CORPORATION*
*  FORT WORTH, TEXAS  *
* ALL RIGHTS RESERVED *
* * * N O T I C E * * *


 (*BLOCKADE.  BY K.M.CHUNG.  4/26/79*)
VAR I,J,SPEED,ABORT,BLNK:INTEGER;
        SCORE,MARK,MOVE,CURSOR:ARRAY(1) OF INTEGER;
PROC PSCORE;
        BEGIN WRITE(SCORE(0)#);
                MEMW(%4020):=%3FFE; (*SET CURSOR*)
                WRITE(SCORE(1)#) END;

PROC BLINK;
VAR T,K,DELAY:INTEGER;
        BEGIN T:=CURSOR(I)-MOVE(I);
                FOR K:=1 TO 30 DO BEGIN
                        FOR DELAY:=1 TO 100 DO;
                        IF MEMW(T)=BLNK THEN MEMW(T):=MARK(I)
                                ELSE MEMW(T):=BLNK
                        END
        END;

BEGIN WRITE('SPEED(1-10)');
        READ(SPEED#); SPEED:=SPEED*10;
        MARK(0):='*'+'*'SHL 8; MARK(1):='('+')'SHL 8;
        BLNK:=' '+' 'SHL 8;
        SCORE(0):=0; SCORE(1):=0;
        REPEAT WRITE(15,28,31); (*TURN OFF CURSOR, CLEAR SCREEN*)
                FOR I:=9 TO 117 DO BEGIN
                        PLOT(I,1,1); PLOT(I,45,1) END;
                FOR I:=1 TO 45 DO BEGIN
                        PLOT(9,I,1); PLOT(10,I,1);
                        PLOT(116,I,1); PLOT(117,I,1) END;
                CURSOR(0):=%3C00+64*4+12;
                CURSOR(1):=%4000-64*4-16;
                FOR J:=0 TO 1 DO MEMW(CURSOR(J)):=MARK(J);
                MOVE(0):=64; MOVE(1):=-64;
                I:=1; ABORT:=0; PSCORE;
                REPEAT UNTIL INKEY<>0; (*HIT KEY TO START*)
                REPEAT I:=1-I;
                        FOR J:=1 TO SPEED DO
                                CASE INKEY OF
                                        'W':MOVE(0):=-64; 'X':MOVE(0):=64;
                                        'D':MOVE(0):=2;        'A':MOVE(0):=-2;
                                        'O':MOVE(1):=-64; '.':MOVE(1):=64;
                                        ';':MOVE(1):=2;        'K':MOVE(1):=-2
                                END;
                        CURSOR(I):=CURSOR(I)+MOVE(I);
                        IF MEMW(CURSOR(I))=BLNK THEN MEMW(CURSOR(I)):=MARK(I)
                        ELSE BEGIN SCORE(1-I):=SCORE(1-I)+1;
                                ABORT:=1; BLINK END
                UNTIL ABORT
        UNTIL SCORE(1-I)>=10
END.

* * * N O T I C E * * *
* PROPRIETARY PROGRAM *
* COPYRIGHT (@) 1979  *
* BY TANDY CORPORATION*
*  FORT WORTH, TEXAS  *
* ALL RIGHTS RESERVED *
* * * N O T I C E * * *

(*PLOT HILBERT CURVES OF ORDERS 1 TO N*)
CONST N=4; H0=32;
VAR I,H,X,Y,X0,Y0,U,V:INTEGER;
PROC MOVE;
VAR I,J:INTEGER;
        FUNC MIN(A,B);
                BEGIN IF A>B THEN MIN:=B ELSE MIN:=A END;
        FUNC MAX(A,B);
                BEGIN IF A<B THEN MAX:=B ELSE MAX:=A END;
        BEGIN FOR I:=MIN(X,U) TO MAX(X,U) DO
                FOR J:=MIN(Y,V) TO MAX(Y,V) DO
                        PLOT(I,J,1);
                U:=X; V:=Y
        END;

PROC P(TYP,I);
        BEGIN IF I>0 THEN
                CASE TYP OF
1:                BEGIN P(4,I-1); X:=X-H; MOVE;
                                P(1,I-1); Y:=Y-H; MOVE;
                                P(1,I-1); X:=X+H; MOVE;
                                P(2,I-1) END;
2:                BEGIN P(3,I-1); Y:=Y+H; MOVE;
                                P(2,I-1); X:=X+H; MOVE;
                                P(2,I-1); Y:=Y-H; MOVE;
                                P(1,I-1) END;
3:                BEGIN P(2,I-1); X:=X+H; MOVE;
                                P(3,I-1); Y:=Y+H; MOVE;
                                P(3,I-1); X:=X-H; MOVE;
                                P(4,I-1) END;
4:                BEGIN P(1,I-1); Y:=Y-H; MOVE;
                                P(4,I-1); X:=X-H; MOVE;
                                P(4,I-1); Y:=Y+H; MOVE;
                                P(3,I-1) END
                END
        END;

BEGIN (*MAIN*)
        WRITE(15,28,31,13,' HILBERT CURVES');
        I:=0; H:=H0; X0:=H DIV 2; Y0:=X0;
        REPEAT I:=I+1; H:=H DIV 2;
                X0:=X0+H DIV 2; Y0:=Y0+H DIV 2;
                X:=X0+(I-1)*32; Y:=Y0+10; U:=X; V:=Y;
                P(1,I)
        UNTIL I=N
END.


* * * N O T I C E * * *
* PROPRIETARY PROGRAM *
* COPYRIGHT (@) 1979  *
* BY TANDY CORPORATION*
*  FORT WORTH, TEXAS  *
* ALL RIGHTS RESERVED *
* * * N O T I C E * * *

(* SAMPLE TINY PASCAL PROGRAM  BY H. YUEN *)
VAR X0,Y0,X,Y,K,F:INTEGER;
BEGIN
        X0:=13000; Y0:=18000; F:=11;
        REPEAT X:=X0; Y:=Y0; WRITE(15,28,31);
                FOR K:=1 TO 1000 DO BEGIN
                        X:=X+Y DIV 4; Y:=Y-X DIV 5;
                        PLOT(X SHR 8,Y SHR 8,1) END;
                X0:=X0+X0 DIV F; Y0:=Y0+Y0 DIV F;
                F:=F+F DIV 6
        UNTIL F>70; WRITE(28,31,'THE SHOW IS OVER')
END.

Here's the DMK file that I extracted it from:

  • M1_Tiny_PASCAL.dmk

    Here's the Go program I wrote to help me extract it:

  • undmk.go
  • (unless otherwise marked) Copyright 2002-2014 YakPeople. All rights reserved.
    (last modified 2020-02-01)       [Login]
    (No back references.)