DECLARE SUB OutputStates (s$) DECLARE SUB Compile (a$) DECLARE SUB DoLto (op$) DECLARE SUB DoRto (op$) DECLARE SUB DoAsm (op$) DECLARE SUB GiveError (e$) DECLARE SUB DoFindStart () DECLARE SUB ProcessLine (a$) DECLARE SUB DoFindReg (op$) DECLARE FUNCTION LabelVal! (Lab$) DECLARE SUB MakeLabel (l$, v!) DECLARE SUB DoGoto (op$) DECLARE SUB DoAdd (op$) DECLARE FUNCTION LabelDefined! (l$) DECLARE SUB DoNot (op$) DECLARE SUB DoInc (op$) DECLARE SUB DoClr (op$) DECLARE SUB DoShl (op$) DECLARE SUB DoMov (op$) DECLARE SUB DoMovE (op$) DECLARE SUB DoFindSReg (op$) DECLARE SUB DoShr (op$) DECLARE SUB DoOut (op$) DECLARE SUB DoMovD (op$) DECLARE FUNCTION LBL$ (i!) DECLARE SUB DoLoop (op$) DECLARE SUB DoMul (op$) DECLARE SUB DoNeg (op$) DECLARE FUNCTION MLAB$ (n!) DECLARE SUB DoInTape (op$) DECLARE FUNCTION IntToBin$ (n!) DECLARE FUNCTION BinToHex$ (b$) DECLARE SUB DoJpos (op$) ' A simple compiler for the Turing machine CONST FALSE = 0, TRUE = NOT FALSE CONST MAXLAB = 400 DIM SHARED Operations$(1, 30) DIM SHARED LabelNames$(MAXLAB) DIM SHARED LabelValues(MAXLAB) COMMON SHARED StatePtr, MOP, CompLevel, LabPtr, CompPass, LabNo i = 0 READ a$ DO WHILE a$ <> "END" Operations$(0, i) = a$ READ Operations$(1, i) i = i + 1 READ a$ LOOP MOP = i - 1 CompLevel = 0 LabPtr = 0 i = INSTR(COMMAND$, " ") IF i = 0 THEN f$ = COMMAND$ ELSE f$ = LEFT$(COMMAND$, i - 1) FOR CompPass = 1 TO 2 StatePtr = 1 LabNo = 0 flno = FREEFILE OPEN f$ FOR INPUT AS #flno DO LINE INPUT #flno, a$ ProcessLine a$ LOOP UNTIL UCASE$(a$) = "END" CLOSE #flno NEXT CompPass '*********************************************************************** ' move one right DATA "R", "0 0 0 R 1; 0 1 1 R 1" ' move one left DATA "L", "0 0 0 L 1; 0 1 1 L 1" ' write a 1 DATA "w1", "0 0 1 L 1; 0 1 1 L 1; 1 0 0 R 2; 1 1 1 R 2" ' write a 0 DATA "w0", "0 0 0 L 1; 0 1 0 L 1; 1 0 0 R 2; 1 1 1 R 2" ' write and move DATA "w0L", "0 0 0 L 1; 0 1 0 L 1" DATA "w0R", "0 0 0 R 1; 0 1 0 R 1" DATA "w1L", "0 0 1 L 1; 0 1 1 L 1" DATA "w1R", "0 0 1 R 1; 0 1 1 R 1" ' scan to (n) occurrences of (s) DATA "Lto", "*", "Rto", "*" ' output in-line hand-written code DATA "ASM", "*" ' find start of registers DATA "FindStart", "*" ' find start (ie. least significant part) of given register DATA "FindReg", "*" ' find end (ie. most significant part) of given register DATA "FindSReg", "*" ' go directly to given state DATA "Goto", "*" ' add two registers together DATA "Add", "*" ' invert a register DATA "Not", "*" ' zero a register DATA "Clr", "*" ' increment a register DATA "Inc", "*" ' shift a register one bit left DATA "Shl", "*" ' shift a register one bit right (arithmetically, ie. top bit preserved) DATA "Shr", "*" ' move (same-sized registers) DATA "Mov", "*" ' move with sign-extend for differently-sized registers DATA "MovE", "*" ' move with de-extend for differently-sized registers DATA "MovD", "*" ' output bit DATA "Out", "*" ' loop while non-zero DATA "Loop", "*" ' negate DATA "Neg", "*" ' multiplication DATA "Mul", "*" ' declare input tape DATA "InTape", "*" ' jump on positive DATA "Jpos", "*" ' end delimiter DATA "END" FUNCTION BinToHex$ (b$) h$ = "" IF (LEN(b$) MOD 8) > 0 THEN b$ = LEFT$(b$ + "0000000", 8 * (LEN(b$) \ 8 + 1)) FOR i = 0 TO LEN(b$) \ 8 - 1 bv = 128 by = 0 FOR j = 0 TO 7 IF MID$(b$, 1 + i * 8 + j, 1) = "1" THEN by = by + bv bv = bv \ 2 NEXT j h$ = h$ + RIGHT$("0" + HEX$(by), 2) NEXT i BinToHex$ = h$ END FUNCTION SUB Compile (a$) CompLevel = CompLevel + 1 IF CompPass = 2 THEN PRINT ";"; SPACE$(CompLevel * 2); ""; a$ IF UCASE$(a$) = "END" THEN IF CompPass = 2 THEN PRINT "END" ELSEIF LEFT$(a$, 1) = ":" THEN IF CompPass = 1 THEN MakeLabel MID$(a$, 2), StatePtr ELSEIF LEFT$(a$, 1) = "#" THEN IF CompPass = 2 THEN PRINT a$ ELSE i = INSTR(a$, " ") IF i = 0 THEN c$ = a$ d$ = "" ELSE c$ = LEFT$(a$, i - 1) d$ = MID$(a$, i + 1) END IF FOR i = 0 TO MOP IF c$ = Operations$(0, i) THEN IF Operations$(1, i) = "*" THEN SELECT CASE c$ CASE "Lto" DoLto d$ CASE "Rto" DoRto d$ CASE "ASM" DoAsm d$ CASE "FindStart" DoFindStart CASE "FindReg" DoFindReg d$ CASE "FindSReg" DoFindSReg d$ CASE "Goto" DoGoto d$ CASE "Add" DoAdd d$ CASE "Not" DoNot d$ CASE "Clr" DoClr d$ CASE "Inc" DoInc d$ CASE "Shl" DoShl d$ CASE "Shr" DoShr d$ CASE "Mov" DoMov d$ CASE "MovE" DoMovE d$ CASE "MovD" DoMovD d$ CASE "Out" DoOut d$ CASE "Loop" DoLoop d$ CASE "Neg" DoNeg d$ CASE "Mul" DoMul d$ CASE "InTape" DoInTape d$ CASE "Jpos" DoJpos d$ END SELECT ELSE OutputStates Operations$(1, i) END IF EXIT FOR END IF NEXT i END IF CompLevel = CompLevel - 1 END SUB SUB DoAdd (op$) ' Uses 9 labels ' Add i j ' ------- ' Adds register _j_ into register _i_ a = INSTR(op$, " ") ri = VAL(LEFT$(op$, a - 1)) rj = VAL(MID$(op$, a + 1)) IF ri > rj THEN Compile "FindReg" + STR$(ri) ProcessLine "L, L, L, w1" FOR i = 1 TO (ri - rj + 1) Compile "Lto 2 1" NEXT i Compile "L" Compile LBL$(0) Compile "ASM 0 0 0 L 1; 0 1 1 L " + LBL$(2) ProcessLine "L, L, w1R" FOR i = 1 TO (ri - rj) Compile "Rto 2 1" NEXT i Compile "ASM 0 0 0 R 1; 0 1 1 R " + LBL$(6) Compile "Rto 2 1" Compile "ASM 0 0 0 L 1; 0 1 1 L 1" ProcessLine LBL$(1) + ", w0L, L, L, L, w1L" FOR i = 1 TO (ri - rj + 1) Compile "Lto 2 1" NEXT i ProcessLine "R, w0L, Goto " + LBL$(0) Compile LBL$(2) ProcessLine "L, L, w1R" FOR i = 1 TO (ri - rj) Compile "Rto 2 1" NEXT i Compile "ASM 0 1 1 R " + LBL$(7) + "; 0 0 0 R 1" Compile "Rto 2 1" Compile "ASM 0 0 1 L 1; 0 1 0 L " + LBL$(4) Compile "Goto " + LBL$(1) Compile LBL$(3) Compile "ASM 0 0 0 L 1; 0 1 1 L " + LBL$(5) ProcessLine "L, L, w1R" FOR i = 1 TO (ri - rj) Compile "Rto 2 1" NEXT i Compile "ASM 0 1 1 R " + LBL$(7) + "; 0 0 0 R 1" Compile "Rto 2 1" Compile "ASM 0 0 1 L " + LBL$(1) + "; 0 1 0 L 1" ProcessLine LBL$(4) + ", w0L, L, L, L, w1L" FOR i = 1 TO (ri - rj + 1) Compile "Lto 2 1" NEXT i ProcessLine "R, w0L, Goto " + LBL$(3) Compile LBL$(5) ProcessLine "L, L, w1R" FOR i = 1 TO (ri - rj) Compile "Rto 2 1" NEXT i Compile "ASM 0 1 1 R " + LBL$(6) + "; 0 0 0 R 1" Compile "Rto 2 1" Compile "ASM 0 0 0 L 1; 0 1 1 L 1" Compile "Goto " + LBL$(4) Compile LBL$(6) Compile "ASM 0 0 0 L " + LBL$(8) + "; 0 1 1 L " + LBL$(8) Compile LBL$(7) Compile "ASM 0 0 1 L 1; 0 1 0 L 1" Compile LBL$(8) Compile "ASM 0 0 0 L 1; 0 1 0 L 1" Compile "FindStart" LabNo = LabNo + 9 ELSE Compile "FindReg" + STR$(ri) ProcessLine "L, L, L, L, L, w1R" FOR i = 1 TO (rj - ri + 1) Compile "Rto 2 1" NEXT i ProcessLine "L, L, L, L" Compile LBL$(0) Compile "ASM 0 0 0 L 1; 0 1 1 L " + LBL$(2) ProcessLine "w1L, L" Compile "ASM 0 0 0 L 1; 0 1 1 R " + LBL$(6) FOR i = 1 TO (rj - ri + 1) Compile "Lto 2 1" NEXT i ProcessLine "R, R, R, R" Compile "ASM 0 0 0 L 1; 0 1 1 L 1" Compile LBL$(1) ProcessLine "L, L, w0L, L, L, L, w1R" FOR i = 1 TO (rj - ri + 1) Compile "Rto 2 1" NEXT i ProcessLine "L, w0L, L, L, Goto " + LBL$(0) Compile LBL$(2) ProcessLine "w1L, L" Compile "ASM 0 0 0 L 1; 0 1 1 R " + LBL$(7) FOR i = 1 TO (rj - ri + 1) Compile "Lto 2 1" NEXT i ProcessLine "R, R, R, R" Compile "ASM 0 0 1 L " + LBL$(1) + "; 0 1 0 L " + LBL$(4) Compile LBL$(3) Compile "ASM 0 0 0 L 1; 0 1 1 L " + LBL$(5) ProcessLine "w1L, L" Compile "ASM 0 0 0 L 1; 0 1 1 R " + LBL$(7) FOR i = 1 TO (rj - ri + 1) Compile "Lto 2 1" NEXT i ProcessLine "R, R, R, R" Compile "ASM 0 0 1 L " + LBL$(1) + "; 0 1 0 L 1" Compile LBL$(4) ProcessLine "L, L, w0L, L, L, L, w1R" FOR i = 1 TO (rj - ri + 1) Compile "Rto 2 1" NEXT i ProcessLine "L, w0L, L, L, Goto " + LBL$(3) Compile LBL$(5) ProcessLine "w1L, L" Compile "ASM 0 0 0 L 1; 0 1 1 R " + LBL$(6) FOR i = 1 TO (rj - ri + 1) Compile "Lto 2 1" NEXT i ProcessLine "R, R, R, R" Compile "ASM 0 0 0 L " + LBL$(4) + "; 0 1 1 L " + LBL$(4) Compile LBL$(6) ProcessLine "R, w0" FOR i = 1 TO (rj - ri + 1) Compile "Lto 2 1" NEXT i ProcessLine "R, R, R, R" Compile "ASM 0 0 0 L " + LBL$(8) + "; 0 1 1 L " + LBL$(8) Compile LBL$(7) ProcessLine "R, w0" FOR i = 1 TO (rj - ri + 1) Compile "Lto 2 1" NEXT i ProcessLine "R, R, R, R" Compile "ASM 0 0 1 L " + LBL$(8) + "; 0 1 0 L " + LBL$(8) Compile LBL$(8) Compile "FindStart" LabNo = LabNo + 9 END IF END SUB SUB DoAsm (op$) ' Uses 0 labels ' ASM states ' ---------- ' Passes the given _states_ directly to the output routine OutputStates op$ END SUB SUB DoClr (op$) ' Uses 0 labels ' Clr i ' ----- ' Zeros register _i_ Compile "FindReg " + op$ Compile "L" Compile "ASM 0 0 0 L 1; 0 1 1 R 3" Compile "ASM 0 0 0 L 1; 0 1 0 L 1" Compile "ASM 0 0 0 L -3; 0 1 1 L -3" Compile "FindStart" END SUB SUB DoFindReg (op$) ' Uses 0 labels ' FindReg i ' --------- ' Moves the head to the least significant end of register _i_ ProcessLine "R, R, R" FOR i = 1 TO VAL(op$) Compile "Rto 2 1" NEXT i ProcessLine "L, L" END SUB SUB DoFindSReg (op$) ' Uses 0 labels ' FindSReg i ' --------- ' Moves the head to the most significant end of register _i_ ProcessLine "R, R" op = VAL(op$) IF op > 1 THEN FOR i = 1 TO op - 1 Compile "Rto 2 1" NEXT i Compile "L" END IF END SUB SUB DoFindStart ' Uses 0 labels ' FindStart ' --------- ' Moves the head to the start of the register section of the tape ProcessLine "Lto 3 1, R" END SUB SUB DoGoto (op$) ' Uses 0 labels ' Goto d ' ------ ' Enters state _d_ directly OutputStates "0 0 0 L 1; 0 1 1 L 1; 1 0 0 R " + op$ + "; 1 1 1 R " + op$ END SUB SUB DoInc (op$) ' Uses 0 labels ' Inc i ' ----- ' Adds one to register _i_ Compile "FindReg " + op$ Compile "L" Compile "ASM 0 0 0 L 1; 0 1 1 R 3" Compile "ASM 0 0 1 L 2; 0 1 0 L 1" Compile "ASM 0 0 0 L -3; 0 1 1 L -3" Compile "FindStart" END SUB SUB DoInTape (op$) ' InTape len1:value1; len2:value2; len3:value3; ... ' ------------------------------------------------- ' Reads the starting value to give the tape as a series of ' register inputs; the _len_ gives the number of bits to ' allocate, and the _value_ the initial value to load; ' the _value_ can be preceded by a '!' character, in which ' case it is converted to a 20-bit fixed-point number with ' 15 bits to the right of the point symb$ = "1110" c$ = op$ DO i = INSTR(c$, ";") IF i = 0 THEN b$ = c$ c$ = "" ELSE b$ = LEFT$(c$, i - 1) c$ = LTRIM$(MID$(c$, i + 1)) END IF a = INSTR(b$, ":") l = VAL(LEFT$(b$, a - 1)) v$ = MID$(b$, a + 1) IF LEFT$(v$, 1) = "!" THEN v = VAL(MID$(v$, 2)) IF v < 0 THEN v = v + 32 v = v * 32768 ELSE v = VAL(v$) END IF v$ = IntToBin$(v) v$ = RIGHT$(STRING$(l, "0") + v$, l) FOR j = 1 TO l symb$ = symb$ + MID$(v$, j, 1) IF j < l THEN symb$ = symb$ + "010" NEXT j symb$ = symb$ + "0110" LOOP UNTIL i = 0 symb$ = LEFT$(symb$, LEN(symb$) - 1) h$ = BinToHex$((symb$)) IF CompPass = 2 THEN PRINT "#hexinput " + h$: PRINT "#input 110(1)" END SUB SUB DoJpos (op$) ' Uses 0 labels ' Jpos r d ' -------- ' If register _r_ is positive, jumps to _d_, else drops through a = INSTR(op$, " ") r = VAL(LEFT$(op$, a - 1)) d$ = MID$(op$, a + 1) Compile "FindSReg" + STR$(r) ProcessLine "R, R" Compile "ASM 0 0 0 L 1; 0 1 1 L 5" Compile "Lto 3 1" Compile "ASM 0 0 0 R " + d$ + "; 0 1 1 R " + d$ Compile "FindStart" END SUB SUB DoLoop (op$) ' Uses 0 labels ' Loop i d ' -------- ' i-- ' if i!=0 goto d; if i==0 fall through a = INSTR(op$, " ") r = VAL(LEFT$(op$, a - 1)) d$ = MID$(op$, a + 1) Compile "FindReg" + STR$(r) ProcessLine "L, L, ASM 0 0 1 L 1; 0 1 0 L 5, L, L" ProcessLine "ASM 0 0 0 L 1; 0 1 1 R 6, ASM 0 0 1 L -3; 0 1 0 L 5" ProcessLine "L, L" ProcessLine "ASM 0 0 0 L 1; 0 1 1 R 6, ASM 0 0 0 L -3; 0 1 1 L 1" ProcessLine "Lto 3 1, ASM 0 0 0 R " + d$ + "; 0 1 1 R " + d$ Compile "FindStart" END SUB SUB DoLto (op$) ' Uses 0 labels ' Lto n s ' ------- ' Moves the head left until just after the first occurrence ' of _n_ consecutive symbol _s_s; the symbol currently under the ' head counts i = INSTR(op$, " ") IF i = 0 THEN GiveError "Bad operand to Lto" ss$ = MID$(op$, i + 1, 1) ' search symbol IF ss$ = "0" THEN os$ = "1" ELSE os$ = "0" ' other symbol hm = VAL(LEFT$(op$, i - 1)) ' how many a$ = "" FOR i = 1 TO hm a$ = a$ + MID$(STR$(i - 1), 2) + " " + os$ + " " + os$ + " L 0; " a$ = a$ + MID$(STR$(i - 1), 2) + " " + ss$ + " " + ss$ + " L " + STR$(i) IF i < hm THEN a$ = a$ + "; " NEXT i OutputStates a$ END SUB SUB DoMov (op$) ' Uses 6 labels ' Mov i j ' ------- ' Loads register _i_ with the contents of register _j_; the ' registers must contain the same number of bits or the results ' are undefined a = INSTR(op$, " ") ri = VAL(LEFT$(op$, a - 1)) rj = VAL(MID$(op$, a + 1)) IF ri < rj THEN Compile "FindReg" + STR$(ri) ProcessLine "L, L, L, L, L, w1R" FOR i = 1 TO (rj - ri + 1) Compile "Rto 2 1" NEXT i ProcessLine "L, L, L, L" Compile LBL$(0) Compile "ASM 0 0 0 L 1; 0 1 1 L " + LBL$(2) ProcessLine "w1L, L" Compile "ASM 0 0 0 L 1; 0 1 1 R " + LBL$(3) FOR i = 1 TO (rj - ri + 1) Compile "Lto 2 1" NEXT i ProcessLine "R, R, R, R, w0L" Compile LBL$(1) ProcessLine "L, L, w0L, L, L, L, w1R" FOR i = 1 TO (rj - ri + 1) Compile "Rto 2 1" NEXT i ProcessLine "L, w0L, L, L, Goto " + LBL$(0) Compile LBL$(2) ProcessLine "w1L, L" Compile "ASM 0 0 0 L 1; 0 1 1 R " + LBL$(4) FOR i = 1 TO (rj - ri + 1) Compile "Lto 2 1" NEXT i ProcessLine "R, R, R, R, w1L, Goto " + LBL$(1) Compile LBL$(3) ProcessLine "R, w0L" FOR i = 1 TO (rj - ri + 1) Compile "Lto 2 1" NEXT i ProcessLine "R, R, R, R, w0, Goto " + LBL$(5) Compile LBL$(4) ProcessLine "R, w0L" FOR i = 1 TO (rj - ri + 1) Compile "Lto 2 1" NEXT i ProcessLine "R, R, R, R, w1" Compile LBL$(5) Compile "FindStart" LabNo = LabNo + 6 ELSE Compile "FindReg" + STR$(ri) ProcessLine "L, L, L, w1L" FOR i = 1 TO (ri - rj) Compile "Lto 2 1" NEXT i Compile "L" Compile LBL$(0) Compile "ASM 0 0 0 L 1; 0 1 1 L " + LBL$(2) ProcessLine "L, L, w1R" FOR i = 1 TO (ri - rj) Compile "Rto 2 1" NEXT i Compile "ASM 0 0 0 R 1; 0 1 1 R " + LBL$(3) ProcessLine "Rto 2 1, w0L" Compile LBL$(1) ProcessLine "w0L, L, L, L, w1L" FOR i = 1 TO (ri - rj + 1) Compile "Lto 2 1" NEXT i Compile "R" Compile "ASM 0 0 0 L " + LBL$(0) + "; 0 1 0 L " + LBL$(0) Compile LBL$(2) ProcessLine "L, L, w1R" FOR i = 1 TO (ri - rj) Compile "Rto 2 1" NEXT i Compile "ASM 0 0 0 R 1; 0 1 1 R " + LBL$(4) Compile "Rto 2 1" Compile "ASM 0 0 1 L " + LBL$(1) + "; 0 1 1 L " + LBL$(1) Compile LBL$(3) Compile "ASM 0 0 0 L 2; 0 1 0 L 2" Compile LBL$(4) ProcessLine "w1L, w0L, FindStart" LabNo = LabNo + 5 END IF END SUB SUB DoMovD (op$) ' Uses 6 labels ' MovD i j ' -------- ' Loads register _i_ with the contents of register _j_; register _i_ ' must be smaller than register _j_; high order bits are lost a = INSTR(op$, " ") ri = VAL(LEFT$(op$, a - 1)) rj = VAL(MID$(op$, a + 1)) IF ri > rj THEN ProcessLine "FindReg" + STR$(ri) + ", L, L, L, w1L" FOR i = 1 TO (ri - rj) Compile "Lto 2 1" NEXT i Compile "L" Compile LBL$(0) Compile "ASM 0 0 0 L 1; 0 1 1 L " + LBL$(2) ProcessLine "L, L, w1R" FOR i = 1 TO (ri - rj + 1) Compile "Rto 2 1" NEXT i Compile "w0L" Compile LBL$(1) ProcessLine "w0L, L, L, L, w1L, L, ASM 0 0 0 L 1; 0 1 1 R " + LBL$(3) FOR i = 1 TO (ri - rj + 1) Compile "Lto 2 1" NEXT i ProcessLine "R, ASM 0 0 0 L " + LBL$(0) + "; 0 1 0 L " + LBL$(0) Compile LBL$(2) ProcessLine "L, L, w1R" FOR i = 1 TO (ri - rj + 1) Compile "Rto 2 1" NEXT i Compile "ASM 0 0 1 L " + LBL$(1) + "; 0 1 1 L " + LBL$(1) Compile LBL$(3) ProcessLine "R, w0L" FOR i = 1 TO (ri - rj + 1) Compile "Lto 2 1" NEXT i ProcessLine "R, w0L, ASM 0 0 0 R 1; 0 1 1 R " + LBL$(4) FOR i = 1 TO (ri - rj) Compile "Rto 2 1" NEXT i ProcessLine "R, ASM 0 0 0 L " + LBL$(5) + "; 0 1 0 L " + LBL$(5) Compile LBL$(4) FOR i = 1 TO (ri - rj) Compile "Rto 2 1" NEXT i ProcessLine "R, w1L" Compile LBL$(5) Compile "FindStart" LabNo = LabNo + 6 ELSE ProcessLine "FindReg" + STR$(ri) + ", L, L, L, L, L, w1R" FOR i = 1 TO (rj - ri + 1) Compile "Rto 2 1" NEXT i ProcessLine "L, L, L, L" Compile LBL$(0) Compile "ASM 0 0 0 L 1; 0 1 1 L " + LBL$(2) Compile "w1L" FOR i = 1 TO (rj - ri + 1) Compile "Lto 2 1" NEXT i ProcessLine "R, R, R, R, w0L" Compile LBL$(1) ProcessLine "L, L, w0L, L, L, L" Compile "ASM 0 0 1 R 1; 0 1 1 R " + LBL$(3) FOR i = 1 TO (rj - ri + 1) Compile "Rto 2 1" NEXT i ProcessLine "L, w0L, L, ASM 0 0 0 L " + LBL$(0) + "; 0 1 1 L " + LBL$(0) Compile LBL$(2) Compile "w1L" FOR i = 1 TO (rj - ri + 1) Compile "Lto 2 1" NEXT i ProcessLine "R, R, R, R, ASM 0 0 1 L " + LBL$(1) + "; 0 1 1 L " + LBL$(1) Compile LBL$(3) FOR i = 1 TO (rj - ri + 1) Compile "Rto 2 1" NEXT i ProcessLine "L, w0L, L, L, ASM 0 0 0 L 1; 0 1 1 L " + LBL$(4) FOR i = 1 TO (rj - ri + 1) Compile "Lto 2 1" NEXT i ProcessLine "R, R, R, R, ASM 0 0 0 L " + LBL$(5) + "; 0 1 0 L " + LBL$(5) Compile LBL$(4) FOR i = 1 TO (rj - ri + 1) Compile "Lto 2 1" NEXT i ProcessLine "R, R, R, R, w1L" Compile LBL$(5) Compile "FindStart" LabNo = LabNo + 6 END IF END SUB SUB DoMovE (op$) ' Uses 6 labels ' MovE i j ' -------- ' Loads register _i_ with the contents of register _j_; register _i_ ' must be larger than register _j_; the top bit is copied into the ' high order bits to give a sign extend a = INSTR(op$, " ") ri = VAL(LEFT$(op$, a - 1)) rj = VAL(MID$(op$, a + 1)) IF ri > rj THEN Compile "FindReg" + STR$(ri) ProcessLine "L, L, L, w1L" FOR i = 1 TO (ri - rj) Compile "Lto 2 1" NEXT i Compile "L" Compile LBL$(0) Compile "ASM 0 0 0 L 1; 0 1 1 L " + LBL$(2) ProcessLine "L, L" Compile "ASM 0 0 1 R 1; 0 1 1 R " + LBL$(3) FOR i = 1 TO (ri - rj + 1) Compile "Rto 2 1" NEXT i Compile "w0L" Compile LBL$(1) ProcessLine "w0L, L, L, L, w1L" FOR i = 1 TO (ri - rj + 1) Compile "Lto 2 1" NEXT i Compile "R" Compile "ASM 0 0 0 L " + LBL$(0) + "; 0 1 0 L " + LBL$(0) Compile LBL$(2) ProcessLine "L, L, ASM 0 0 1 R 1; 0 1 1 R " + LBL$(4) FOR i = 1 TO (ri - rj + 1) Compile "Rto 2 1" NEXT i Compile "ASM 0 0 1 L " + LBL$(1) + "; 0 1 1 L " + LBL$(1) Compile LBL$(3) FOR i = 1 TO (ri - rj + 1) Compile "Rto 2 1" NEXT i ProcessLine "w0L, w0L, L, ASM 0 0 0 L -3; 0 1 1 L " + LBL$(5) Compile LBL$(4) FOR i = 1 TO (ri - rj + 1) Compile "Rto 2 1" NEXT i ProcessLine "w1L, w0L, L, ASM 0 0 0 L -3; 0 1 1 L 1" Compile LBL$(5) Compile "FindStart" LabNo = LabNo + 6 ELSE Compile "FindReg" + STR$(ri) ProcessLine "L, L, L, L, L, w1R" FOR i = 1 TO (rj - ri + 1) Compile "Rto 2 1" NEXT i ProcessLine "L, L, L, L" Compile LBL$(0) Compile "ASM 0 0 0 L 1; 0 1 1 L " + LBL$(2) ProcessLine "w1L, L" Compile "ASM 0 0 0 L 1; 0 1 1 R " + LBL$(3) FOR i = 1 TO (rj - ri + 1) Compile "Lto 2 1" NEXT i ProcessLine "R, R, R, R, w0L" Compile LBL$(1) ProcessLine "L, L, w0L, L, L, L, w1R" FOR i = 1 TO (rj - ri + 1) Compile "Rto 2 1" NEXT i ProcessLine "L, w0L, L, ASM 0 0 0 L " + LBL$(0) + "; 0 1 1 L " + LBL$(0) Compile LBL$(2) ProcessLine "w1L, L, ASM 0 0 0 L 1; 0 1 1 R " + LBL$(4) FOR i = 1 TO (rj - ri + 1) Compile "Lto 2 1" NEXT i ProcessLine "R, R, R, R, ASM 0 0 1 L " + LBL$(1) + "; 0 1 1 L " + LBL$(1) Compile LBL$(3) ProcessLine "R, w0L" FOR i = 1 TO (rj - ri + 1) Compile "Lto 2 1" NEXT i ProcessLine "R, w0R, R, R, w0L, L, L" Compile "ASM 0 0 0 L -3; 0 1 1 R " + LBL$(5) Compile LBL$(4) ProcessLine "R, w0L" FOR i = 1 TO (rj - ri + 1) Compile "Lto 2 1" NEXT i ProcessLine "R, w0R, R, R, w1L, L, L" Compile "ASM 0 0 0 L -3; 0 1 1 R 1" Compile LBL$(5) Compile "FindStart" LabNo = LabNo + 6 END IF END SUB SUB DoMul (op$) ' Uses 35 labels ' Mul i j ' ------- ' Multiplies the contents of register _i_ by those of register _j_ ' and puts the result in register _i_; the numbers are treated as ' signed fixed-point binary numbers with 15 bits to the right of ' the binary point SL = LabNo a = INSTR(op$, " ") ri = VAL(LEFT$(op$, a - 1)) rj = VAL(MID$(op$, a + 1)) Compile "MovE 3" + STR$(ri) Compile "Mov 4" + STR$(rj) Compile "Clr 2" ProcessLine "Clr 1, FindSReg 3, R, R" Compile "ASM 0 0 0 R " + MLAB$(SL + 12) + "; 0 1 1 R 1" ProcessLine "FindStart, Neg 3, Inc 1, Goto 5" Compile MLAB$(SL + 12) ProcessLine "FindStart, FindSReg 4, R, R" Compile "ASM 0 0 0 R " + MLAB$(SL + 13) + "; 0 1 1 R 1" ProcessLine "FindStart, Neg 4, Inc 1, Goto 5" ProcessLine MLAB$(SL + 13) + ", FindStart" ProcessLine "FindReg 4, L, L" Compile MLAB$(SL + 14) ProcessLine "L, w1R, ASM 0 0 0 L 1; 0 1 1 L " + MLAB$(SL + 16) ProcessLine "L, FindStart" Compile MLAB$(SL + 15) ProcessLine "Shl 3, Goto " + MLAB$(SL + 26) Compile MLAB$(SL + 16): LabNo = SL + 17 ProcessLine "FindStart, Add 2 3, Goto " + MLAB$(SL + 15) Compile MLAB$(SL + 26) FOR i = 1 TO 4: Compile "Rto 2 1": NEXT i ProcessLine "ASM 0 0 0 R 1; 0 1 0 L 7, Rto 2 1, L, w0L, L" Compile "ASM 0 0 0 L " + MLAB$(SL + 14) + "; 0 1 1 L " + MLAB$(SL + 14) Compile "FindStart" ProcessLine "FindReg 1, L, L, ASM 0 0 0 L 1; 0 1 1 L 7" ProcessLine "FindStart, Goto " + MLAB$(SL + 27) ProcessLine "L, L, L, Neg 2" Compile MLAB$(SL + 27): LabNo = SL + 28 Compile "Clr 5" Compile "Not 5" Compile MLAB$(SL + 28): LabNo = SL + 29 Compile "Shr 2" Compile "Loop 5 " + MLAB$(SL + 28) Compile "MovD" + STR$(ri) + " 2" LabNo = LabNo + 35 END SUB SUB DoNeg (op$) ' Uses 0 labels ' Neg i ' ----- ' Negates register _i_ Compile "FindReg " + op$ Compile "L" Compile "ASM 0 0 0 L 1; 0 1 1 R 7" Compile "ASM 0 0 0 L 1; 0 1 1 L 5" Compile "ASM 0 0 0 L -3; 0 1 1 L -3" Compile "L" Compile "ASM 0 0 0 L 1; 0 1 1 R 3" Compile "ASM 0 0 1 L 1; 0 1 0 L 1" Compile "ASM 0 0 0 L -3; 0 1 1 L -3" Compile "FindStart" END SUB SUB DoNot (op$) ' Uses 0 labels ' Not i ' ----- ' Inverts register _i_ Compile "FindReg " + op$ Compile "L" Compile "ASM 0 0 0 L 1; 0 1 1 R 3" Compile "ASM 0 0 1 L 1; 0 1 0 L 1" Compile "ASM 0 0 0 L -3; 0 1 1 L -3" Compile "FindStart" END SUB SUB DoOut (op$) ' Uses 0 labels ' Out b ' ----- ' Outputs _b_ to the section of tape to the left of the register ' delimiter; 0 becomes 0, 1 becomes 01 Compile "Lto 2 1" ProcessLine "R, R" IF op$ = "0" THEN Compile "w0L" ELSE ProcessLine "w1L, w0L" END IF ProcessLine "w1L, w1R" ProcessLine "Rto 3 1, L, L, L" END SUB SUB DoRto (op$) ' Uses 0 labels ' Rto n s ' ------- ' Moves the head right until just after the first occurrence ' of _n_ consecutive symbol _s_s; the symbol currently under the ' head counts i = INSTR(op$, " ") IF i = 0 THEN GiveError "Bad operand to Lto" ss$ = MID$(op$, i + 1, 1) ' search symbol IF ss$ = "0" THEN os$ = "1" ELSE os$ = "0" ' other symbol hm = VAL(LEFT$(op$, i - 1)) ' how many a$ = "" FOR i = 1 TO hm a$ = a$ + MID$(STR$(i - 1), 2) + " " + os$ + " " + os$ + " R 0; " a$ = a$ + MID$(STR$(i - 1), 2) + " " + ss$ + " " + ss$ + " R " + STR$(i) IF i < hm THEN a$ = a$ + "; " NEXT i OutputStates a$ END SUB SUB DoShl (op$) ' Uses 0 labels ' Shl i ' ----- ' Shifts register _i_ left one bit; low order bit is set to zero Compile "FindReg " + op$ Compile "L" Compile "ASM 0 0 0 L 1; 0 1 1 R 7" Compile "ASM 0 0 0 L 1; 0 1 0 L 5" Compile "ASM 0 0 0 L -3; 0 1 1 L -3" Compile "L" Compile "ASM 0 0 0 L 1; 0 1 1 R 3" Compile "ASM 0 0 1 L -3; 0 1 1 L 1" Compile "ASM 0 0 0 L -3; 0 1 1 L -3" Compile "FindStart" END SUB SUB DoShr (op$) ' Uses 0 labels ' Shr i ' ----- ' Shifts register _i_ right one bit; high order bit is preserved, ' ie. effects an arithmetic shift right Compile "FindSReg " + op$ ProcessLine "R, R" Compile "ASM 0 0 0 R 4; 0 1 1 R 8" Compile "R" Compile "ASM 0 0 0 R 1; 0 1 1 L 7" Compile "ASM 0 0 0 R 1; 0 1 0 R 5" Compile "ASM 0 0 0 R -3; 0 1 1 R -3" Compile "R" Compile "ASM 0 0 0 R 1; 0 1 1 L 3" Compile "ASM 0 0 1 R -3; 0 1 1 R 1" Compile "ASM 0 0 0 R -3; 0 1 1 R -3" Compile "FindStart" END SUB SUB GiveError (e$) PRINT PRINT "TCOMP: "; e$ SOUND 880, 4 END END SUB FUNCTION IntToBin$ (n) ' Returns the binary representation of _n_. a$ = "" DO IF (n MOD 2) THEN a$ = "1" + a$ ELSE a$ = "0" + a$ n = n \ 2 LOOP WHILE n > 0 IntToBin$ = a$ END FUNCTION FUNCTION LabelDefined (l$) ' Returns whether label l$ has already been defined found = FALSE IF LabPtr > 0 THEN FOR i = 0 TO LabPtr - 1 IF LabelNames$(i) = l$ THEN found = TRUE: EXIT FOR NEXT i END IF LabelDefined = found END FUNCTION FUNCTION LabelVal (Lab$) found = FALSE IF LabPtr = 0 THEN GiveError "Label `" + Lab$ + "' undefined" FOR i = 0 TO LabPtr - 1 IF LabelNames$(i) = Lab$ THEN found = TRUE: EXIT FOR NEXT i IF NOT found THEN GiveError "Label `" + Lab$ + "' undefined" LabelVal = LabelValues(i) END FUNCTION FUNCTION LBL$ (i) LBL$ = ":_L" + MID$(STR$(LabNo + i), 2) END FUNCTION SUB MakeLabel (l$, v) IF LabPtr > MAXLAB THEN GiveError "out of label table space" IF LabelDefined(l$) THEN GiveError "label `" + l$ + "' already defined" LabelNames$(LabPtr) = l$ LabelValues(LabPtr) = v LabPtr = LabPtr + 1 END SUB FUNCTION MLAB$ (n) MLAB$ = ":_L" + MID$(STR$(n), 2) END FUNCTION SUB OutputStates (s$) DIM bit$(5) ' s$ is the string of states to output in the form ' "i s t m j; i s t m j; ..." ' where i is state in, s is symbol read, t is symbol to write, ' m is direction to move, j is state to enter mss = 0 ' maximum state number seen ss$ = s$ DO a = INSTR(ss$, ";") IF a = 0 THEN ts$ = ss$ ss$ = "" ELSE ts$ = LEFT$(ss$, a - 1) ss$ = LTRIM$(MID$(ss$, a + 1)) END IF FOR i = 1 TO 5 b = INSTR(ts$, " ") IF i < 5 THEN bit$(i) = LEFT$(ts$, b - 1) ts$ = MID$(ts$, b + 1) ELSE bit$(i) = ts$ END IF NEXT i IF VAL(bit$(1)) > mss THEN mss = VAL(bit$(1)) IF CompPass = 2 THEN PRINT RTRIM$(STR$(VAL(bit$(1)) + StatePtr)); ", "; bit$(2); ", "; PRINT bit$(3); ", "; bit$(4); ","; IF LEFT$(bit$(5), 1) = ":" THEN PRINT LabelVal(MID$(bit$(5), 2)) ELSEIF LEFT$(bit$(5), 1) = "!" THEN PRINT VAL(MID$(bit$(5), 2)) ELSE PRINT VAL(bit$(5)) + StatePtr END IF END IF LOOP UNTIL a = 0 StatePtr = StatePtr + mss + 1 END SUB SUB ProcessLine (a$) c$ = a$ DO i = INSTR(c$, ",") IF i = 0 THEN b$ = c$ c$ = "" ELSE b$ = LEFT$(c$, i - 1) c$ = LTRIM$(MID$(c$, i + 1)) END IF Compile b$ LOOP UNTIL i = 0 END SUB