| YaK:: TRS-80 Tiny Pascal Compiler Source ( PASCAL COMPILER V2 12/11/78 V.TRS-80 3/02/79 ) | [Changes] [Calendar] [Search] [Index] [PhotoTags] |
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:
Here's the Go program I wrote to help me extract it:
| (last modified 2020-02-01) [Login] |