˙!!!! 14-NOV-80 ! EMAS VERSION OF LAYOUT, ALTERED FOR INTERDATA ! CHANGED AGAIN TO DO SINGLE PAGES ON DEMAND. ! 19-9-80: changed so Pragma printer will underline properly ! CAP,CAPO,CAPSH,CAPSHO,INVERT,INVERTO defaulted out ! 4-11-80: 'include' option implemented ! ASSIGN parameter lookup changed to strings from packed chars ! PSR modification to look for input.LAY if input not found. %BEGIN !* DOCUMENT LAYOUT PROGRAM !* SYMBOLIC CONSTANTS %CONSTINTEGER command stream = 0 %OWNINTEGER SIN = 1; ! SOURCE INPUT STREAM %CONSTINTEGER LSIN = 3; ! DITTO %CONST %INTEGER ERR=0,out=1 ! Define various types of output possible - only one per run %constinteger output types = 4; ! no. of types %constinteger printer = 1, update = 2, merge = 3, index = 4, daisy = 5 %conststring(11)%array operating mode(1:5) = "PRINTER", "UPDATE", "MERGE", "INDEX", "DAISY" %owninteger output type = printer; ! default %owninteger inclusion mode = 1; ! 0 => merge, 1 => copy INCLUDE references by name %include "Sysinc:command.inc" %externalpredicatespec Exists(%string(31) File) %string(63) parm = command_parameter; ! start parameter:- MOUSES dependent %string(31) IN1= command_in1 %string(31) OUT1= command_out1 %CONST %INTEGER LBOUND=200; !LINE BUFF BOUND %CONST %INTEGER ABOUND=200; !ATOM BUFF BOUND %CONST %INTEGER SBOUND=200; !SOURCE LINE BUFF BOUND %CONST %INTEGER TBOUND=25; !TAB BOUND %CONST %INTEGER ESCBIT=256,UNDBIT=128,CASEBIT=32 %CONST %INTEGER CHARMASK=255,BASICMASK=127,LETMASK=95 %CONST %INTEGER SENTSP=544; !512+' ' %CONSTINTEGER JUSTBIT = X'8000' !LAYOUT PARAMETERS %OWN %INTEGER TOP=2,BOTTOM=4,LEFT=0,PAGE=60,LINE=72 %OWN %INTEGER SLINE=80,NLS=1,SGAP=2,PGAP=3 %OWN %INTEGER INDENT=0,PAGENO=0,START=1,FINISH=9999 !!!!%OWN %INTEGER CAP='@',UND='_',CAPSH='.',UNDSH='%',INVERT=32 %owninteger cap=0, und='_',capsh=0,undsh='%',invert=0 %integer capo = cap, und˙o = und, capsho = capsh, undsho = undsh %integer inverto = invert %owninteger at line = 1, old at line %string(35) include file = ""; %integer include stream %string(35) output ident %OWN %INTEGER ASCII=1,JUST=0,MARK=0,ESCAPE='$' %OWN %INTEGER IGNORE=0, SECTNO=0 %OWNINTEGER DLPI=6, DCPI=10, DPAGE=1700 %OWNINTEGER DLEFT=250, DTOP=250 %OWN %INTEGER %ARRAY TAB(0:25)= %C 1,9,17,25,33,41,49,57,65,73,81, 89,97,105,113,121,129,137,145,153,161,169,177,185,193, 201 %OWN %INTEGER XLINES=0,LINECAPIND=0,LINEUNDIND=0,LINEMIDIND=0 %OWNINTEGER DBUFFP=0 %OWN %INTEGER INDENTIND=1,ERRIND=0,XPAGE=1 %OWN %INTEGER COLS=0; !COLUMNS USED ON CURRENT LINE %OWNINTEGER LHM=1 %OWN %INTEGER TEXTCOLS=0; !LAST COL OCCUPIED %OWN %INTEGER LINES=0; !LINES PRINTED ON CURRENT PAGE %OWN %INTEGER PAGES=0; !TOTAL PAGES PRINTED %OWN %INTEGER FIXED=0; !FIXED COLUMNS %OWN %INTEGER GAPS=0,SGAPS=0; !TOTAL GAPS, SENTENCE GAPS %OWN %INTEGER SIZE=0; !SIZE OF CURRENT ATOM %OWN %INTEGER SMAX=0; !UPDATED SOURCE POINTER %OWN %INTEGER INDENTCOL=1 %OWN %INTEGER NEXT=0 %INTEGER DIRECTIVE,RELIND,FREELIST,NUM %INTEGERARRAY DBUFF(1:LBOUND); !DIABLO BUFFER %INTEGER %ARRAY BUFF(1:LBOUND); !LINE BUFFER %INTEGER %ARRAY ABUFF(1:ABOUND); !ATOM BUFFER %INTEGER %ARRAY SBUFF(1:SBOUND); ! SOURCE LINE (UPDATED) ! VARIABLES ASSOCIATED WITH SINGLE PAGE PRINTING %CONSTINTEGER PPS = 1024; ! PAGES PER SECTION %CONSTINTEGER PRINT MAX = 30 %RECORDFORMAT PRINTFM(%SHORTINTEGER SECTION, PAGE) %RECORD(PRINTFM)%ARRAY PRINT LIST(1:PRINT MAX) %OWNINTEGER LAST PRINT = 0, NEXT PRINT = 1 %INTEGER %ARRAY TYPE(0:127); ! FOR SYMBOL INPUT. %INTEGER %ARRAY LINK(1:65),HEAD,TAIL(1:500) %PREDICATE TO BE PRINTED(%INTEGER LINE) %RECORD(PRINTFM)%NAME P; %OWNINTEGER PRINT=0 %TRUE %IF LAST PRINT = 0; ! PRINT LIST EMPTY %IF LINE # 0 %START; ! FOR SPEED:- NOT AT START OF PAGE SO ˙ %FALSE %IF PRINT = 0; ! SIMPLY REPEAT PREVIOUS DECISION %TRUE %FINISH P == PRINT LIST(NEXT PRINT) %IF SECTNO*PPS+PAGENO > P_SECTION*PPS+P_PAGE %START NEXT PRINT = NEXT PRINT+1 %STOP %IF NEXT PRINT > LAST PRINT P == PRINT LIST(NEXT PRINT) %FINISH %IF P_SECTION = SECTNO %AND (P_PAGE = PAGENO %OR P_PAGE = PPS-1) %START PRINT = 1; %TRUE %FINISH PRINT = 0; %FALSE %END %ROUTINE READCH(%INTEGERNAME CH) %OWNINTEGER E = 0 %on 9 %start ->ended %finish %CYCLE %if e = 0 %start read symbol(ch) at line = at line+1 %if ch = nl %return %finish Ended: at line = 1 %if include file # "" %start close input; select input(sin) include file = "" at line = old at line inclusion mode = |inclusion mode| %continue %finish %IF SIN#LSIN %START SIN = SIN+1; SELECTINPUT(SIN) %ELSE E = NL %IF E='E' E = 'E' %IF E=escape E = escape %IF E=0 CH = E; %RETURN %FINISH %REPEAT %END %ROUTINE FAULT(%INTEGER N) %SWITCH S(1:17) SELECTOUTPUT(ERR) print symbol('*') %if include file # "" %start print string("file "); print string(include file) space %finish print string("line"); write(at line,3); print string(": ") ->S(N) S(1): PRINTSTRING("FAULTY FORMAT AT ") PRINTSYMBOL(NEXT) ->A9 S(2): PRINTSTRING("INVALID ASSIGNMENT TO SYMBOL PARAMETER"); ->A9 S(3): PRINTSTRING("UNKNOWN NAME"); ->A9 S(4): PRINTSTRING("SCALAR/VECTOR MISMATCH"); ->A9 S(5): PRINTSTRING("UNKNOWN DIRECTIVE "); ->A8 S(6): PRINTSTRING("SPURIOUS DIRECTIVE "); ->A8 S(7): PRINTSTRING("OUT OF BOUNDS "); ->A8 S(8): PRINTSTRING("OFF PAGE "); ->A8 S(9): PRINTSTRING("OVER TEXT "); ->A8 S(10): PRINTSTRING( %C "TOO MANY PARAMETER VALUES NEST˙ED - RUN ABANDONED") ->A9 S(11): PRINTSTRING("NO VALUE STORED "); ->A9 S(12): PRINT STRING("MISPLACED DIRECTIVE "); -> A8 S(13): PRINT STRING("TOO MANY PRINT VALUES"); -> A9 S(14): PRINT STRING("DUPLICATE PRINT REQUEST"); -> A9 s(15): print string("Unknown output type = "); print string(output ident) -> A9 s(16): print string("Nested - INCLUDE="); print string(include file) -> A9 s(17): print string("$X: index atom missing?") -> A9 A8: PRINTSYMBOL(DIRECTIVE) PRINTSYMBOL(RELIND) %IF RELIND#0 A9: ERRIND=1 NEWLINE %END %integerfn output name(%string(35) name) %integer j,k,sym j = 0 %for k = 1,1,length(name) %cycle sym = charno(name,k) %if sym # ' ' %start sym = sym-'a'+'A' %if 'a' <= sym <= 'z' j = j+1; charno(name,j) = sym %finish %repeat length(name) = j %result = printer %if j = 0 %for k = 1,1,output types %cycle %result = k %if operating mode(k) = name %repeat fault(15); ! unknown output type %result = printer; ! default it %end %ROUTINE READ ATOM OR DIRECTIVE %INTEGER K,C,U,ATOMCAPIND,ATOMUNDIND %INTEGER STATOM %SWITCH SW(0:8) %IF NEXT=0 %THEN READCH(K) %ELSE K=NEXT %AND NEXT=0 DIRECTIVE=0; SIZE=0 %IF IGNORE#0 %THEN %START %CYCLE READCH(K) %WHILE K#ESCAPE READCH(K) DIRECTIVE=K&LETMASK %IF DIRECTIVE='A' %OR DIRECTIVE='E' %C %THEN READCH(NEXT) %AND %RETURN READCH(K) %REPEAT %FINISH %IF K&ESCBIT#0 %THEN %START; ! DIRECTIVE READ IN LAST CALL. DIRECTIVE=K&LETMASK READCH(NEXT) %RETURN %FINISH ATOMCAPIND=LINECAPIND; ATOMUNDIND=LINEUNDIND; STATOM=0 U=ATOMUNDIND; C=ATOMCAPIND %CYCLE ->SW(TYPE(K&BASICMASK)&15) SW(1): ! CAPSH. RECOGNISED AT START OF ATOM O ->TOBUFF %UNLESS STATOM=0; STATOM=1 ATOMCAPIND=CASEBIT; C=CASEBIT ->LOOP S˙W(2): ! ESCAPE READCH(K); K=K+ESCBIT ->TOBUFF %UNLESS 'A'<=K&LETMASK<='Z' %OR K&LETMASK = NL %EXIT %IF SIZE#0 DIRECTIVE=K&LETMASK READCH(NEXT) %RETURN SW(3): ! CAP C=CASEBIT; STATOM=1 ->LOOP SW(4): ! UND U=UNDBIT; STATOM=1 READCH(K); ->TOBUFF %IF K&BASICMASK=' ' ->SW(TYPE(K&BASICMASK)&15) SW(6): ! UNDSH STATOM=1 ATOMUNDIND=UNDBIT U=UNDBIT ->LOOP SW(7): ! SPACE OR NEWLINE %EXIT %IF K=NL %OR K!LINEUNDIND=' '; ->TOBUFF SW(8): ! LETTERS K=K!!INVERT K=K-C %IF 'a'<=K&BASICMASK<='z' !* NOTE THAT HERE 'a' AND 'z' ARE LOWER CASE. SW(0): ! EVERYTHING ELSE TOBUFF: STATOM=1; SIZE=SIZE+1; ABUFF(SIZE)=K!U U=ATOMUNDIND; C=ATOMCAPIND LOOP: READCH(K) %REPEAT NEXT=K %RETURN %IF ATOMUNDIND=0 %OR SIZE=0 !* REMOVES UNDERLINE FROM TERMINATING PUNCTUATION - BUT NOT IF SET BY UND K=ABUFF(SIZE)!!UNDBIT ABUFF(SIZE)=K %IF K='.' %OR K=',' %OR K=':' %OR K=';' %C %OR K=')' %OR K='!' %OR K='?' %END %ROUTINE PRINTSOURCELINE %INTEGER I %IF ERRIND#0 %START SELECTOUTPUT(ERR) I=0 I=I+1 %AND PRINTSYMBOL(SBUFF(I)) %WHILE I#SMAX NEWLINE ERRIND=0 %FINISH SMAX=0 %AND %RETURN %IF output type # update %or inclusion mode < 0 SELECTOUTPUT(out) I=0 I=I+1 %AND PRINTSYMBOL(SBUFF(I)) %WHILE I#SMAX NEWLINE; SMAX=0 %END %ROUTINE STORE(%INTEGER K) SMAX=SMAX+1; SBUFF(SMAX)=K %END %routine nstore(%integer n) %routine strip %integer k k = rem(n,10) n = (n-k)//10 strip %if n # 0 store(k+'0') %end strip; store(' ') %end; ! ... of NSTORE %ROUTINE STORESOURCEATOM !* IN GENERAL, THE UNDERLINE AND CAPITALISE OUTPUT PARAMETERS ARE USED !* IF NOT DISABLED. ALL LETTERS AR˙E SET TO LOWER CASE, WITH !* APPROPRIATE SYMBOL PARAMETERS, AND THEN INVO IS APPLIED. THIS !* SWITCHES THEM BACK, IF INVO IS NON-ZERO, TO U.C. !* IF AN OUTPUT DEVICE ACCEPTED THE 8TH BIT SET AS SIGNIFYING UNDERLINING, !* SETTING UNDO AND UNDSHO TO 0 WOULD CAUSE THE 8TH BIT TO BE SET TO !* SIGNIFY UNDERLINING. %INTEGER I,K,ATOMCAPIND,ATOMUNDIND %ROUTINE TRANSLATEUNDERLINE %INTEGER P,Q K=K-UNDBIT %AND %RETURN %IF LINEUNDIND#0 ->ONE %IF K-UNDBIT=' ' K=K-UNDBIT %AND %RETURN %IF ATOMUNDIND#0 ->ONE %IF UNDSHO=0 P=I %WHILE P#SIZE %CYCLE P=P+1; Q=ABUFF(P) ->ONE %IF Q&UNDBIT=0 %AND (P#SIZE %OR (Q#'.' %C %AND Q#',' %AND Q#':' %AND Q#';' %AND Q#')' %C %AND Q#'!' %AND Q#'?')) %REPEAT STORE(UNDSHO); K=K-UNDBIT; ATOMUNDIND=1 %RETURN ONE: %RETURN %IF UNDO=0 STORE(UNDO); K=K-UNDBIT %END %return %if output type # update %or inclusion mode < 0 %IF SMAX#0 %AND XLINES=0 %START %IF SMAX+SIZE+1<=SLINE %THEN STORE(' ') %C %ELSE PRINTSOURCELINE %FINISH ATOMCAPIND=0; ATOMUNDIND=0 %IF LINECAPIND=0 %AND CAPSHO#0 %AND SIZE>=2 %START %CYCLE I=1,1,SIZE K=ABUFF(I)&BASICMASK ATOMCAPIND=0 %AND %EXIT %IF 'A'<=K-CASEBIT<='Z' !LC ATOMCAPIND=1 %IF 'A'<=K<='Z'; !UC %REPEAT %FINISH STORE(CAPSHO) %IF ATOMCAPIND#0 %CYCLE I=1,1,SIZE K=ABUFF(I) TRANSLATEUNDERLINE %IF K&UNDBIT#0 K=K+CASEBIT %IF 'A'<=K<='Z' %AND (LINECAPIND#0 %C %OR ATOMCAPIND#0) STORE(CAPO) %AND K=K+CASEBIT %IF 'A'<=K<='Z' %AND CAPO#0 K=K!!INVERTO %IF 'A'<=K&LETMASK<='Z' STORE(ESCAPE) %IF K&ESCBIT#0 STORE(K&CHARMASK) %REPEAT %END %ROUTINE SETCOLUMN(%INTEGER M) !* THIS MOVES TO COL M-1 SO THAT THE NEXT ATOM STARTS AT COL M. !* FIXED IS SET TO SUPPRESS A SPACE BEING INSERTED BEFORE THAT ATOM, AND !* TO INHIBIT JUSTIFICATION TO THE LEFT OF THIS POINT. !* ON ENTRY, COLS GIVES THE LAST COLUMN USED˙. %IF 1<=M<=LINE %START M=M-1 %IF M>COLS %START COLS=COLS+1 %AND BUFF(COLS)=' ' %UNTIL COLS=M %FINISH %ELSE %START %WHILE COLS#M %CYCLE FAULT(9) %AND %EXIT %IF BUFF(COLS)#' ' COLS=COLS-1 %REPEAT LHM = COLS+1 %FINISH %FINISH %ELSE %START FAULT(8); INDENTCOL=1 %IF INDENTCOL=M %FINISH FIXED=COLS; GAPS=0; SGAPS=0 %END %ROUTINE MARKDOC %INTEGER J; %CONSTINTEGER BELL = 7 %IF MARK=1 %START PRINTSYMBOL('='); SPACES(LINE-2); PRINTSYMBOL('=') NEWLINE %ELSE %IF MARK = 2 PRINTSYMBOL(12) %ELSE %IF MARK = 3 SELECT OUTPUT(ERR) J = 8 PRINT SYMBOL(BELL) %AND J = J-1 %UNTIL J = 0; NEWLINE SELECT OUTPUT(out) SELECT INPUT(command stream) SKIP SYMBOL %WHILE NEXT SYMBOL # NL SKIP SYMBOL SELECT INPUT(SIN) %FINISH %END %ROUTINE RESETDOCLINE %IF XLINES#0 %START XLINES=XLINES-1 %IF XLINES=0 %START LINECAPIND=0; LINEUNDIND=0 LINEMIDIND=0; INDENTIND=1 %FINISH %FINISH LHM = 1 TEXTCOLS=0; COLS=0; FIXED=0; XPAGE=0 SETCOLUMN(INDENTCOL) %IF INDENTIND#0 %END %ROUTINE PRINTLPLINE %CONST %INTEGER CR=13 %INTEGER I,J,K,L,M,U,V ! method of underlining changed to suit Pragma printer %integer ul = 0 %IF PAGES+1>=START %AND TO BE PRINTED(LINES-NLS) %START SELECTOUTPUT(out) %IF LINES=NLS %START MARKDOC %IF MARK#0 NEWLINES(TOP) %FINISH %IF TEXTCOLS#0 %START L=LEFT L=L+(LINE-COLS)//2 %IF LINEMIDIND#0 SPACES(L) U=UNDBIT; V=BASICMASK U=0 %AND V=CHARMASK %IF ASCII=0 %CYCLE I=1,1,COLS K=BUFF(I) ul = i %if k & undbit # 0 PRINTSYMBOL(K&V) %REPEAT %if ul # 0 %start printsymbol(CR) spaces(l) %for i = 1,1,ul %cycle k = ' ' k = '_' %if buff(i) & undbit # 0 print symbol(k) %repeat ˙ %finish %FINISH NEWLINES(NLS) %IF LINES>=PAGE %AND BOTTOM#0 %START %IF PAGENO=0 %START NEWLINES(BOTTOM) %FINISH %ELSE %START I=BOTTOM//2 NEWLINES(I) SPACES(LEFT+LINE//2-4) %IF SECTNO#0 %START WRITE(SECTNO,1); WRITE(-PAGENO,1) %FINISHELSE WRITE(PAGENO,1) NEWLINES(BOTTOM-I) %FINISH %FINISH %FINISH %END %ROUTINE PRINTDIABLOLINE %endoflist !! %INTEGER LI,L,K,I,J,DIR,P,PLAST !! %OWNINTEGER VDIFF=0, HDIFF=0, VPOS=0, HPOS=0, OLDCOL=0 !! %CONSTINTEGER HOLD = 240; ! 128+64+48 !! %CONSTINTEGER MLEFT=212; !128+64+16+4 !! %CONSTINTEGER MRIGHT= 208; !128+64+16 !! %CONSTINTEGER DOWN= 224; !128+64+32 !!%CONSTINTEGER ESC=27, HT=9, VT=11, FF=12, GRAPHICS ON='6' !! %ROUTINE SET GRAPHICS MODE !! PRINT SYMBOL(ESC); PRINT SYMBOL(GRAPHICS ON) !! %END !! %ROUTINE MOVE !! %IF HDIFF#0 %START !! HPOS = HPOS+HDIFF; HDIFF = 0 !! PRINT SYMBOL(ESC); PRINT SYMBOL(HT); PRINT SYMBOL(HPOS) !! %FINISH !! %IF VDIFF#0 %START !! VPOS = VPOS+VDIFF; VDIFF = 0 !! PRINT SYMBOL(ESC); PRINT SYMBOL(VT); PRINT SYMBOL(VPOS) !! %FINISH !! %END !! %ROUTINE DRESET !! PRINTSYMBOL(MRIGHT); PRINTSYMBOL(0) !! PRINTSYMBOL(DOWN); PRINTSYMBOL(0) !! %END !! %ROUTINE DSPACES(%INTEGER N) !! HDIFF = HDIFF+(60//DCPI)*N !! %END !! %ROUTINE DNEWLINES(%INTEGER N) !! VDIFF = VDIFF+N*(48//DLPI) !! %END !! %ROUTINE DCR !! HDIFF = -HPOS !! %END !! %ROUTINE DNEWPAGE !! HDIFF = -HPOS !! VDIFF = (DPAGE*12)//25-VPOS !! VDIFF = 0 %IF VDIFF<0 !! MOVE !! VPOS = 0 !! PRINTSYMBOL(HOLD) %IF PAGES#FINISH !! %END !! %ROUTINE DINCSP(%INTEGER N) !! HDIFF = HDIFF+N !! HDIFF = HDIFF-N-N %IF DIR<0 !! %END !! %ROUTINE DPRINTCH(%INTEGER C) !! %IF DIR<0 %THEN HDIFF = HDIFF-60//DCPI !! %IF C#' ' %START !! MOVE; PRINTSYMBOL('_') %IF C&UNDBIT#0 !! C = C&1˙27 !! PRINTSYMBOL(C) %IF C#' ' !! %FINISH !! %IF DIR>0 %THEN HDIFF = HDIFF+60//DCPI !! %END !! %ROUTINE DWRITE(%INTEGER N) !! %INTEGER M !! M = N//10; N = N-M*10 !! DWRITE(M) %IF M#0; DPRINTCH('0'+N) !! %END !! !! LI = LINES+NLS; DIR = 1 !! %IF PAGES+1>=START %AND TO BE PRINTED(LINES) %START !! SELECTOUTPUT(out) !! %IF LI=NLS %START !! %IF PAGES = 0 %START !! PRINT SYMBOL(FF); SET GRAPHICS MODE !! %ELSE !! DNEWPAGE !! %FINISH !! DRESET; OLDCOL = 0 !! VDIFF = (DTOP*48)//100 !! DNEWLINES(TOP) !! %FINISH !! %IF TEXTCOLS#0 %START !! DCR; HDIFF = HDIFF+(DLEFT*60)//100 !! L = LEFT !! %IF LINEMIDIND#0 %START !! L = LINE-COLS !! DINCSP(30//DCPI) %IF L&1#0 !! L = LEFT+L//2 !! %FINISH !! DSPACES(L) !! %IF LHM-OLDCOL>OLDCOL-COLS %START !! DIR = 1; P = LHM; PLAST = DBUFFP+1 !! DSPACES(LHM-1) !! %IF PLAST=1 %THEN PLAST = COLS+1 !! %ELSE !! DIR = -1; P = DBUFFP; PLAST = LHM-1 !! %IF P=0 %THEN P = COLS %AND DSPACES(P) %C !! %ELSE DSPACES(LINE) !! %FINISH !! %WHILE P#PLAST %CYCLE !! %IF DBUFFP=0 %THEN K = BUFF(P) %ELSE K = DBUFF(P) !! OLDCOL = P !! P = P+DIR !! %IF K&JUSTBIT#0 %THEN DINCSP(K-JUSTBIT) %C !! %ELSE DPRINTCH(K&511) !! %REPEAT !! %FINISH !! DNEWLINES(NLS) !! DIR = 1 !! %IF LI>=PAGE %AND BOTTOM#0 %START !! %IF PAGENO#0 %START !! DNEWLINES(BOTTOM//2); DCR; HDIFF = HDIFF+(DLEFT*60)//100 !! I = 1; I = 2 %IF PAGENO>=10 !! I = 3 %IF PAGENO>=100; I = 4 %IF PAGENO>=1000 !! I = I+2 %IF SECTNO#0; I = I+1 %IF SECTNO>=10 !! DSPACES(LEFT); DSPACES((LINE-I)//2) !! DINCSP(30//DCPI) %IF I&1#0 !! %IF SECTNO#0 %START !! DWRITE(SECTNO); DPRINTCH('-') !! ˙ %FINISH !! DWRITE(PAGENO) !! %FINISH !! %FINISH !! %FINISH !! DBUFFP = 0 %list %END %ROUTINE PRINTDOCLINE lines = lines + nls %if output type = printer %start print LP line %else %if output type = daisy print diablo line %finish %if lines >= page %start lines = 0; pages = pages+1 page no = page no + 1 %if page no # 0 %finish reset doc line %END %ROUTINE JUSTIFY %OWN %INTEGER FLIP=0 %INTEGER I,J,K,L,MIN,COUNT,SCOUNT,AWAIT,SWAIT,AGAPS %INTEGER DX1,DX2,DX3 COUNT=LINE-COLS %RETURN %IF COUNT<=0 %OR GAPS=0 %endoflist !!!! JUSTIFY FOR DIABLO !!! SCOUNT = COUNT*(60//DCPI); !EXTRA SIXTIETHS !!! DX1 = SCOUNT//GAPS; !EXTRA PER GAP !!! DX2 = SCOUNT-DX1*GAPS; !REMAINDER !!! DX3 = 0 !!! %IF DX2>SGAPS %START; !CANT FIT REST IN SGAPS !!! DX3 = DX2-SGAPS; DX2 = SGAPS !!! %FINISH !!! AGAPS = GAPS !!! %CYCLE I = COLS,-1,1 !!! K = BUFF(I) !!! %IF AGAPS>0 %START !!! %IF K=SENTSP %OR K=' ' %START !!! AGAPS = AGAPS-1 !!! J = JUSTBIT+DX1+60//DCPI !!! %IF K=SENTSP %AND DX2>0 %START !!! DX2 = DX2-1; J = J+1 !!! %FINISH !!! %IF DX3>0 %START !!! DX3 = DX3-1; J = J+1 !!! %FINISH !!! K = J !!! %FINISH !!! %FINISH !!! DBUFF(I) = K !!! %REPEAT DBUFFP = COLS %list AGAPS=GAPS-SGAPS; ! ATOM GAPS MIN=COUNT//GAPS; ! MIN NO OF SPACES TO BE ADDED TO EVERY COUNT=COUNT-MIN*GAPS; ! SPACES TO BE ADDED AS WELL AS MIN AT !* SENTENCE GAPS ARE FILLED IN PREFERENCE TO ATOM GAPS. SCOUNT=SGAPS; SCOUNT=COUNT %IF COUNT0 %OR TEXTCOLS#0 !* I.E. FAULT IF $L NOT FINISHED OR, WITH $L0, OFF LHM, WHEN !* DIRECTIVE ENCOUNTERED. XLINES=1; RESETDOCLINE %FINISH %IF DIRECTIVE = NL %START STORE(' ') %IF SMAX # 0; STORE(ESCAPE) %FINISH %IF TEXTCOLS#0 %AND 'C'#DIRECTIVE#'T' %and directive # 'X' %START JUSTIFY %IF JUST#0 %AND DIRECTIVE='J' PRINTDOCLINE PRINTSOURCELINE %IF SMAX#0 %FINISH PRINTSOURCELINE %IF SMAX+5>SLINE %RETURN %IF DIRECTIVE = NL STORE(' ') %IF SMAX#0 STORE(ESCAPE); STORE(DIRECTIVE) READNUM %if directive # 'X'; !cross-ref? ->S(DIRECTIVE) S('A'): !ASSIGN %CYCLE ASSIGN SKIP %WHILE NEXT#';' %AND NEXT#NL %EXIT %IF NEXT=NL SKIP %REPEAT INVERT=32 %IF INVERT#0; INVERTO=32 %IF INVERTO#0 PAGE=9999 %IF PAGE<=0 FAULT(7) %AND INDENT=0 %UNLESS 0<=INDENT<=TBOUND INDENTCOL=TAB(INDENT) SETCOLUMN(INDENTCOL) ->S('N') %IF IGNORE#0 %RETURN S('B'): !BLANKS %IF LINES#0 %OR XPAGE#0 %START; ! NOTE XPAGE SET BY $N TO 1. NUM=(NUM-xpage)*NLS; ! n-1 IFF after forcible page turn NUM=PAGE-LINES %IF PAGE-LINES0 %FINISH %RETURN S('C'): !COL NUM=COLS+1+NUM %IF RELIND#0 SETCOLUMN(NUM) %RETURN S('E'): !END PRINTDOCLINE %WHILE LINES#0 %AND PAGE<999 FINISH=PAGES; NEXT=NL %RETURN S('I'): !INDENT NUM=INDENT+NUM %IF RELIND#0 FAULT(7) %AND NUM=0 %UNLESS 0<=NUM<=TBOUND NUM=TAB(NUM) SETCOLUMN(NUM) %RETURN S('J'): !JUSTIFY (DONE) %RETURN S('L'): !LINES XLINES=NUM; XLINES=-1 %IF XLINES=0 INDENTIND=0 %WHILE NEXT#NL %CYCLE LINECAPIND=CASEBIT %IF NEXT&LETMASK='C' LINEUNDIND=UNDBIT %IF NEXT&LETMASK='U' LINEMIDIND=1 %IF NEXT&LE˙TMASK='M' INDENTIND=1 %IF NEXT&LETMASK='I' SKIP %REPEAT COLS=0 %AND FIXED=0 %IF INDENTIND=0 %RETURN S('N'): !NEWPAGE S('S'): %RETURN %IF PAGE>=999 PRINTDOCLINE %WHILE LINES#0 XPAGE=1 %IF DIRECTIVE='S' %AND SECTNO # 0 %START SECTNO = SECTNO+1 %IF SECTNO # 0; PAGENO=1 %FINISH %RETURN S('P'): !PARAGRAPH %IF LINES#0 %START NUM=NUM*NLS NUM=PAGE-LINES %IF PAGE-LINES0 %FINISH SETCOLUMN(COLS+1+PGAP) %RETURN S('T'): !TAB %IF RELIND#0 %START T=0; C=COLS+1 %IF RELIND='+' %START %WHILE NUM>0 %CYCLE T=T+1 %UNTIL T>TBOUND %OR TAB(T)>C FAULT(7) %AND %RETURN %IF T>TBOUND C=TAB(T) NUM=NUM-1 %REPEAT %FINISH %ELSE %START T=T+1 %UNTIL T>TBOUND %OR TAB(T)>=C %WHILE NUM<0 %CYCLE T=T-1 %UNTIL T<0 %OR TAB(T)= Q_SECTION*PPS+Q_PAGE %START L = P_˙SECTION; M = P_PAGE P_SECTION = Q_SECTION; P_PAGE = Q_PAGE Q_SECTION = L; Q_PAGE = M SWOP = 1 %FINISH %REPEAT %EXIT %IF SWOP = 0 %REPEAT %FOR J = 1,1,LAST PRINT-1 %CYCLE P == PRINT LIST(J); Q == PRINT LIST(J+1) %IF P_SECTION = Q_SECTION %AND P_PAGE = Q_PAGE %START FAULT(14); %RETURN %FINISH %REPEAT %RETURN %else %if i = 37; ! INCLUDE file fault(1) %and %return %if next # '='; skip fault(16) %if include file # ""; ! already including read string(include file) include stream = lsin; include stream = 1 %if sin # 1; !**** LSIN > 1??? open input(include stream, include file) select input(include stream) old at line = at line; at line = 1 %if inclusion mode = 0 %start; ! literal merge into update smax = 0; ! delete INCLUDE line %else print source line; ! copy INCLUDE line inclusion mode = -1; ! don't copy body to update %finish %return %else %if i = 38; ! define OUTPUT type fault(1) %and %return %if next # '='; skip read string(output ident) %if pages = 0 = lines %start output type = output name(output ident) %else fault(12); ! misplaced directive %finish %return %FINISH %IF NEXT='<' %OR NEXT='>' %START J=I %CYCLE %IF NEXT='<' %START NEWCELL(MAP(J),LINK(J)) %FINISH %ELSE %START FAULT(11) %AND %RETURN %IF LINK(J)=0 %IF 1<=J<=6 %AND TYPE(MAP(J))&15=J %START K=MAP(J) %CYCLE TYPE(K)=TYPE(K)>>4 %EXIT %IF TYPE(K)=0 %OR MAP(TYPE(K)&15)=K %REPEAT %FINISH MAP(J)=HEAD(LINK(J)) TYPE(MAP(J))=TYPE(MAP(J))<<4!J %IF 1<=J<=6 POP(LINK(J)) %FINISH J=J+1 ˙ %EXIT %IF J=65 %REPEAT SKIP %UNTIL NEXT#' ' %RETURN %IF NEXT=';' %OR NEXT=NL %FINISH FAULT(1) %AND %RETURN %IF NEXT#'=' %CYCLE SKIP %UNTIL NEXT#' ' %IF 'A'<=NEXT&LETMASK<='Z' %START ! RHS ALSO PARAMETER. READNAME(J); %RETURN %IF J=0 %FINISH %ELSE %START J=0 %IF NEXT='''' %START SKIP; !QUOTEMARK NUM=NEXT; SKIP; !QUOTED SYMBOL SKIP; !QUOTEMARK (PRESUMABLY) %FINISH %ELSE %START READNUM NUM=MAP(I)+NUM %IF RELIND#0 %FINISH %FINISH %IF 1<=I<=6 %AND TYPE(MAP(I))&15=I %START K=MAP(I) !* MAP(I) IS CURRENTLY ACTIVE, I.E. ITS ENTRY IN TYPE REFERS TO IT. %CYCLE TYPE(K)=TYPE(K)>>4 %EXIT %IF TYPE(K)=0 %OR MAP(TYPE(K)&15)=K %REPEAT %FINISH %CYCLE MAP(I)=MAP(J); ! N.B. MAP(0)==NUM. TYPE(MAP(I))=TYPE(MAP(I))<<4!I %IF 1<=I<=6 I=I+1; J=J+1 %EXIT %IF JNAMEMAX %REPEAT FAULT(1) %UNLESS NEXT=';' %OR NEXT=NL %routine read string(%string(35)%name s) %integer k,sym s = "" %cycle sym = next & 127; %exit %if sym = ';' %or sym = NL skip %if sym # ' ' %start sym = sym-'a'+'A' %if 'a' <= sym <= 'z' s = s.tostring(sym) %if length(s) # 35 %finish %repeat %end; ! read string %routine get(%integername k) k = 0 %and %return %unless 'A' <= next & let mask <= 'Z' k = next & let mask; skip %end %ROUTINE READNAME(%INTEGER %NAME ORDINAL) %string(7) ident %integer sym %conststring(7)%array name(1:name max) = "CAPSH", ˙ "ESCAPE", "CAP", "UND", "spare", "UNDSH", "NLS", "SGAP", "PGAP", "INDENT", "TOP", "BOTTOM", "LEFT", "PAGE", "LINE", "SLINE", "INVERT", "CAPO", "UNDO", "CAPSHO", "UNDSHO", "INVERTO", "ASCII", "JUST", "MARK", "START", "FINISH", "PAGENO", "IGNORE", "SECTNO", "DLPI", "DCPI", "DLEFT", "DPAGE", "DTOP" ,"PRINT", "INCLUDE", "OUTPUT", "SPLAT", "TAB" skip %while next=' ' ident = "" %cycle get(sym); %exit %if sym = 0 ident = ident.tostring(sym) %if length(ident) # 7 %repeat fault(1) %and ordinal = 0 %and %return %if ident = "" %for ordinal = 1,1,name max %cycle %return %if name(ordinal) = ident %repeat fault(3); ordinal=0 %END; !READ NAME %INTEGER %MAP MAP(%INTEGER I) %SWITCH S(0:NAME MAX) %RESULT ==TAB(I-(NAMEMAX-1)) %IF I>=NAMEMAX ->S(I) S(0): %RESULT ==NUM S(1): %RESULT ==CAPSH S(2): %RESULT ==ESCAPE S(3): %RESULT ==CAP S(4): %RESULT ==UND S(6): %RESULT ==UNDSH S(7): %RESULT ==NLS S(8): %RESULT ==SGAP S(9): %RESULT ==PGAP S(10): %RESULT ==INDENT S(11): %RESULT ==TOP S(12): %RESULT ==BOTTOM S(13): %RESULT ==LEFT S(14): %RESULT ==PAGE S(15): %RESULT ==LINE S(16): %RESULT ==SLINE S(17): %RESULT ==INVERT S(18): %RESULT ==CAPO S(19): %RESULT ==UNDO S(20): %RESULT ==CAPSHO S(21): %RESULT ==UNDSHO S(22): %RESULT ==INVERTO S(23): %RESULT ==ASCII S(24): %RESULT ==JUST S(25): %RESULT ==MARK S(26): %RESULT ==START S(27): %RESULT ==FINISH S(28): %RESULT ==PAGENO S(29): %RESULT ==IGNORE S(30): %RESULT ==SECTNO S(31): %RESULT == DLPI S(32): %RESULT == DCPI S(33): %RESULT == DLEFT S(34): %RESULT == DPAGE S(35): %RESULT == DTOP ! 36 = PRINT ! 37 = INCLUDE ! 38 = OUTPUT s(39): %signal 15,15 ! 40 = TAB s(*): %result == num; ! all the odds and sods %END; !MAP %ROUTINE READ N(%SHO˙RTINTEGERNAME N) SKIP %WHILE NEXT = ' ' N = 0 %IF NEXT = '?' %START SKIP %ELSE %WHILE '0' <= NEXT <= '9' %CYCLE N = 10*N + NEXT - '0' SKIP %REPEAT %FINISH %END; ! READ N %END; !ASSIGN %END; !PROCESS DIRECTIVE ! =================== IT ALL STARTS HERE ===================== %unless exists(in1) %start %if exists(in1.".lay") %start in1 = in1.".lay" %else printstring("* LAYOUT fails -- ".in1." does not exist") newline %stop %finish %finish open input(1, in1); open output(1, out1) select input(1); select output(1) output type = output name(parm) %if output type = printer %start print symbol(12); ! initial page throw %else %if output type = merge inclusion mode = 0 output type = update %else %if output type = index inclusion mode = 0 %finish PROMPT(">") %CYCLE NUM=0,1,127; TYPE(NUM)=0 %REPEAT %CYCLE NUM='A',1,'Z'; TYPE(NUM)=8 %REPEAT %CYCLE NUM='A'!32,1,'Z'!32; TYPE(NUM)=8 %REPEAT TYPE(CAPSH)=1; TYPE(ESCAPE)=2; TYPE(CAP)=3 TYPE(UND)=4; TYPE(UNDSH)=6 TYPE(' ')=7; TYPE(NL)=7 SELECTINPUT(SIN) SELECTOUTPUT(out) %CYCLE FREELIST=1,1,65 LINK(FREELIST)=0 %REPEAT %CYCLE FREELIST=1,1,500 HEAD(FREELIST)=FREELIST-1 %REPEAT %WHILE PAGES= Q_SECTION*PPS+Q_PAGE %START L = P_SECTION; M = P_PAGE P_SECTION = Q_SECTION; P_PAGE = Q_PAGE Q_SECTION = L; Q_PAGE = M SWOP = 1 %FINISH %REPEAT %EXIT %IF SWOP = 0 %REPEAT %FOR J = 1,1,LAST PRINT-1 %CYCLE P == PRINT LIST(J); Q == PRINT LIST(J+1) %IF P_SECTION = Q_SECTION %AND P_PAGE = Q_PAGE %START FAULT(14); %RETURN %FINISH %REPEAT %RETURN %else %if i = 37; ! INCLUDE file fault(1) %and %return %if next # '='; skip fault(16) %if include file # ""; ! already including read string(include file) include stream = lsin; include stream = 1 %if sin # 1; !**** LSIN > 1??? open input(include stream, include file) select input(include stream) old at line = at line; at line = 1 %if inclusion mode = 0 %start; ! literal merge into update smax = 0; ! delete INCLUDE line %else print source line; ! copy INCLUDE line inclusion mode = -1; ! don't copy body to update %finish %return %else %if i = 38; ! define OUTPUT type fault(1) %and %return %if next # '='; skip read string(output ident) %if pages = 0 = lines %start output type = output name(output ident) %else fault(12); ! misplaced directive %finish %return %FINISH %IF NEXT='<' %OR NEXT='>' %START J=I %CYCLE %IF NEXT='<' %START NEWCELL(MAP(J),LINK(J)) %FINISH %ELSE %START FAULT(11) %AND %RETURN %IF LINK(J)=0 %IF 1<=J<=6 %AND TYPE(MAP(J))&15=J %START K=MAP(J) %CYCLE TYPE(K)=TYPE(K)>>4 %EXIT %IF TYPE(K)=0 %OR MAP(TYPE(K)&15)=K %REPEAT %FINISH ˙ MAP(J)=HEAD(LINK(J)) TYPE(MAP(J))=TYPE(MAP(J))<<4!J %IF 1<=J<=6 POP(LINK(J)) %FINISH J=J+1 %EXIT %IF J=65 %REPEAT SKIP %UNTIL NEXT#' ' %RETURN %IF NEXT=';' %OR NEXT=NL %FINISH FAULT(1) %AND %RETURN %IF NEXT#'=' %CYCLE SKIP %UNTIL NEXT#' ' %IF 'A'<=NEXT&LETMASK<='Z' %START ! RHS ALSO PARAMETER. READNAME(J); %RETURN %IF J=0 %FINISH %ELSE %START J=0 %IF NEXT='''' %START SKIP; !QUOTEMARK NUM=NEXT; SKIP; !QUOTED SYMBOL SKIP; !QUOTEMARK (PRESUMABLY) %FINISH %ELSE %START READNUM NUM=MAP(I)+NUM %IF RELIND#0 %FINISH %FINISH %IF 1<=I<=6 %AND TYPE(MAP(I))&15=I %START K=MAP(I) !* MAP(I) IS CURRENTLY ACTIVE, I.E. ITS ENTRY IN TYPE REFERS TO IT. %CYCLE TYPE(K)=TYPE(K)>>4 %EXIT %IF TYPE(K)=0 %OR MAP(TYPE(K)&15)=K %REPEAT %FINISH %CYCLE MAP(I)=MAP(J); ! N.B. MAP(0)==NUM. TYPE(MAP(I))=TYPE(MAP(I))<<4!I %IF 1<=I<=6 I=I+1; J=J+1 %EXIT %IF JNAMEMAX %REPEAT FAULT(1) %UNLESS NEXT=';' %OR NEXT=NL %routine read string(%string(35)%name s) %integer k,sym s = "" %cycle sym = next & 127; %exit %if sym = ';' %or sym = NL skip %if sym # ' ' %start sym = sym-'a'+'A' %if 'a' <= sym <= 'z' s = s.tostring(sym) %if length(s) # 35 %finish %repeat %end; ! read string %routine get(%integername k) k = 0 %and %return %unless 'A' <= next & let mask <= 'Z' k = next & let mask; skip %end ˙ %ROUTINE READNAME(%INTEGER %NAME ORDINAL) %string(7) ident %integer sym %conststring(7)%array name(1:name max) = "CAPSH", "ESCAPE", "CAP", "UND", "spare", "UNDSH", "NLS", "SGAP", "PGAP", "INDENT", "TOP", "BOTTOM", "LEFT", "PAGE", "LINE", "SLINE", "INVERT", "CAPO", "UNDO", "CAPSHO", "UNDSHO", "INVERTO", "ASCII", "JUST", "MARK", "START", "FINISH", "PAGENO", "IGNORE", "SECTNO", "DLPI", "DCPI", "DLEFT", "DPAGE", "DTOP" ,"PRINT", "INCLUDE", "OUTPUT", "SPLAT", "TAB" skip %while next=' ' ident = "" %cycle get(sym); %exit %if sym = 0 ident = ident.tostring(sym) %if length(ident) # 7 %repeat fault(1) %and ordinal = 0 %and %return %if ident = "" %for ordinal = 1,1,name max %cycle %return %if name(ordinal) = ident %repeat fault(3); ordinal=0 %END; !READ NAME %INTEGER %MAP MAP(%INTEGER I) %SWITCH S(0:NAME MAX) %RESULT ==TAB(I-(NAMEMAX-1)) %IF I>=NAMEMAX ->S(I) S(0): %RESULT ==NUM S(1): %RESULT ==CAPSH S(2): %RESULT ==ESCAPE S(3): %RESULT ==CAP S(4): %RESULT ==UND S(6): %RESULT ==UNDSH S(7): %RESULT ==NLS S(8): %RESULT ==SGAP S(9): %RESULT ==PGAP S(10): %RESULT ==INDENT S(11): %RESULT ==TOP S(12): %RESULT ==BOTTOM S(13): %RESULT ==LEFT S(14): %RESULT ==PAGE S(15): %RESULT ==LINE S(16): %RESULT ==SLINE S(17): %RESULT ==INVERT S(18): %RESULT ==CAPO S(19): %RESULT ==UNDO S(20): %RESULT ==CAPSHO S(21): %RESULT ==UNDSHO S(22): %RESULT ==INVERTO S(23): %RESULT ==ASCII S(24): %RESULT ==JUST S(25): %RESULT ==MARK S(26): %RESULT ==START S(27): %RESULT ==FINISH S(28): %RESULT ==PAGENO S(29): %RESULT ==IGNORE S(30): %RESULT ==SECTNO S(31): %RESULT == DLPI S(32): %RESULT == DCPI S(33): %RESULT == DLEFT S(34): %RESULT == DPAGE S(35): %RESULT == DTOP ! 36 = PRINT ! 37 = INCLUDE ! 38 = OUTPUT s(39): %signa˙l 15,15 ! 40 = TAB s(*): %result == num; ! all the odds and sods %END; !MAP %ROUTINE READ N(%SHORTINTEGERNAME N) SKIP %WHILE NEXT = ' ' N = 0 %IF NEXT = '?' %START SKIP %ELSE %WHILE '0' <= NEXT <= '9' %CYCLE N = 10*N + NEXT - '0' SKIP %REPEAT %FINISH %END; ! READ N %END; !ASSIGN %END; !PROCESS DIRECTIVE ! =================== IT ALL STARTS HERE ===================== %unless exists(in1) %start %if exists(in1.".lay") %start in1 = in1.".lay" %else printstring("* LAYOUT fails -- ".in1." does not exist") newline %stop %finish %finish open input(1, in1); open output(1, out1) select input(1); select output(1) output type = output name(parm) %if output type = printer %start print symbol(12); ! initial page throw %else %if output type = merge inclusion mode = 0 output type = update %else %if output type = index inclusion mode = 0 %finish PROMPT(">") %CYCLE NUM=0,1,127; TYPE(NUM)=0 %REPEAT %CYCLE NUM='A',1,'Z'; TYPE(NUM)=8 %REPEAT %CYCLE NUM='A'!32,1,'Z'!32; TYPE(NUM)=8 %REPEAT TYPE(CAPSH)=1; TYPE(ESCAPE)=2; TYPE(CAP)=3 TYPE(UND)=4; TYPE(UNDSH)=6 TYPE(' ')=7; TYPE(NL)=7 SELECTINPUT(SIN) SELECTOUTPUT(out) %CYCLE FREELIST=1,1,65 LINK(FREELIST)=0 %REPEAT %CYCLE FREELIST=1,1,500 HEAD(FREELIST)=FREELIST-1 %REPEAT %WHILE PAGES Enter %if K = 0 -> Fail1 %if GG >= 0 K = K-Order Bit G = G+1 %repeat %finish %return Fail0:K = Error + 3 ; pos1 = 0 ; -> Failed {TOO COMPLEX} Fail1:K = Atom1 Failed: %if K&Error = 0 %then Fault(2) %else Fault(K&255) %end ! ! >> COMPILE << ! %routine Compile %const %integer Real Dom = 0 %const %integer Int Dom = 1 %const %integer String Dom = 2 %const %integer Temp String Dom = 3 %switch C ( 0: First Action-1 ) %integer Class %string(8) Name = "" %integer Count = 0 %integer Next = SS %integer Link = 0 %integer Line %integer X, N %integer Pend Pr %byte %array Dom Stack (0:20) %byte %name Dom == Dom Stack(0) %byte %name BN ! ! >> GET NEXT << ! %routine Get Next %record(Arfm) %name P GN: %if Next = 0 %start ! End of Phrase Class = 0 %and %return %if Link = 0 P == Ar(Link) Next = P_Link Link = P_Sub %finish %cycle P == Ar(Next) X = P_Sub Class = P_Class %exit %if Class < First Act˙ion %if X = 0 %start ! Null phrase Next = P_Link ; -> GN %finish %if P_Link # 0 %start ! Follow a phrase P_Sub = Link Link = Next %finish Next = X %repeat Next = P_Link %if Diag&Diag Compiler # 0 %start Spaces(8-Length(Name)) %unless Name = "" Name = Text(Class) Write(X, 2) Space Print String(Name) Sm read item; -> er1 %if type # 1 -> restore %finish %if sym = '%' %start read sym; -> erq %if sym < 'A' code = sym&95; !upper-case read sym -> pc(symtype(code)>>4&7) %finish dir = 0 %if video > 0 %start clear line; print symbol('=') print symbol(sym) echo = 1 %finish ! C o m m a n d i n p u t: m a i n l o o p more: !(command code has been read) hold = type; -> er2 %if hold < 4 -> er0 %if hold < 8 %and newtop = 0; !no changes when Showing ci = ci+1; -> er6 %if ci >= cbound-3 code = sym; !command letter ref = 0; num = 1; scope = 1; !default values read item -> c(hold) c(8): !Find minus scope = 0 c(4): !+ Delete, Uncover c(9): !+ Traverse, Verify %if type = 0 %start; !followed by number scope = num read item %finish num = 0; !as indicator (not I,S) c(5): !+ Insert, Substitute hold = sym; -> er4 %if type # 3; !not valid quote mark -> ti = ti+1; ref = ti; !REF indexes first quoted symbol %cycle read sym %if sym = nl %start; !closing quote omitted -> er4 %if num = 0; !allowed only for I,S pend = sym; sym = hold %finish %exit %if sym = hold -> er6 %˙if ti > tbound-2 sym = sym&casemask %if 'a' <= sym <= 'z' %and num = 0 text(ti) = sym; ti = ti+1 %repeat -> er4 %if ti = ref %and num = 0; !null allowed only for I,S text(ti) = 0; !end-marker num = 1; !restore default read item -> nput c(6): !Erase c(10): !+ Move, Print minus c(7): !+ Get, Kill, etc c(11): !+ Left, Right, etc -> er1 %if type = 3; !(redundant, but better report) -> nput c(12): !open bracket code = '[' -> comma c(13): !comma code = '^' ! read item %if type = 1; !permit line break (better not?) comma: ref = chain; chain = ci -> put c(14): !close bracket unchain; -> er3 %if ref = 0 code = ']'; r(ref)_count = num nput: read item %if type = 0; !get %own %string(*)%name line {Current command line} %own %integer inp {Position in line} %own %integer sym, sym type {Last char extracted from line} ! ! Symbol types: ! ! 0 a A . SP NL o ( ! : : : # t [ ! 9 z Z $ h { ! : e < ! _ r - ! ! 0 1 2 3 4 5 6 128+closing bracket ! (128+NL for '-') ! %constbytearray Type(0:127) = 6 {?}, 6 {?}, 6 {?}, 6 {?}, 6 {?}, 6 {?}, 6 {?}, 6 {?}, 6 {?}, 6 {?}, 5 {?}, 6 {?}, 6 {?}, 6 {?}, 6 {?}, 6 {?}, 6 {?}, 6 {?}, 6 {?}, 6 {?}, 6 {?}, 6 {?}, 6 {?}, 6 {?}, 6 {?}, 6 {?}, 6 {?}, 6 {?}, 6 {?}, 6 {?}, 6 {?}, 6 {?}, 4 { }, 6 {!}, 6 {"}, 3 {#}, 3 {$}, 6 {%}, 6 {&}, 6 {'}, 128+')', 6 {)}, 9 {*}, 9 {+}, 6 {,},128+NL, 3 {.}, 6 {/}, 0 {0}, 0 {1}, 0 {2}, 0 {3}, 0 {4}, 0 {6}, 0 {0}, 0 {7}, 0 {8}, 0 {9}, 3 {:}, 6 {;},128+'>',6 {=}, 6 {>}, 6 {?}, 6 {@}, 2 {A}, 2 {B}, 2 ˙{C}, 2 {D}, 2 {E}, 2 {F}, %cycle print symbol (sym) get sym %repeat print symbol ('?'); newline %return %finish {Do the command} %if skipping = 0 %or char no(command_command,1) = '$' %start %if flag = 0 %start {Executable program} Run Program (Program) {Loaded before command parse} %else %if flag < 0 {An obeyfile} Obey (Obey File,"Out:",Command_Parameter) %else LoadX (Command_Command,Program_Spec) {load external} Run Program (Program) %finish %finish Close All(0) %end %externalroutine DO(%string(127) What) DoIt(What) %end %system %integer ECHO OBEY = -1 !Normally 0 (no echo) or 1 (echo on). Only negative at very beginning, !to let SUBSYSTEM (at label STARTUP) decide whether it has just started !or just come back from an Int:. %routine Show Elapsed %owninteger Elapsed = 0 Printstring(Time) N = Cputime Print((N-Elapsed)//1000, 5,1) Elapsed = N Printstring(" CPU seconds") Newline %end %external %routine OBEY (%string(31) from,to, %string(63) params) %own %string(127) line %record(FD fm)%name FD, old command, old report %record(Parmpfm) Parm %integer j, nparms, old echo Obey = ECHO Obey, old skip = SKIPPING %integer Old Segs = Current Segs, Old work segs = Work Segs, Base Load %record(Progfm) Prog %on stream error %start {End of .COM file or $EXIT} Obey Level = Obey Level-1 Work Segs = Old work segs Current Segs = Old segs Close in (0); Close out (0,0) In stream(0) == old command Out stream(0) == old report select input(0); select output(0) {Restore buffers, which were saved in the files} Read block (old command_key, old command_Bn, addr(old command_buf)) %c %if old command_key # 0 Read block (old report_key, old report_Bn+1, addr(old report_buf)) %c %if old report_key # 0 ˙ SKIPPING = old skip ECHO Obey = old echo Obey %return %finish Parmp == Parm %if Obey Level = 1 %start Relocate(Loaded(Loaded Files)) %if Loadup(Prog, Batch File) %finish Obey Level = Obey Level+1 Base Load = Loaded Files+1 %if Echo Obey < 0 %start {first entry} Echo Obey = 0 Run(Subinit) %finish %routine Get Line %integer Sym Prompt(Command Prompt) Line = "" %cycle Sym = Readsymbol; %exit %if Sym = Nl %if Sym = '&' %and Nextsymbol = Nl %start Skipsymbol %else Line = Line.Tostring(Sym) %finish %repeat Console(Prompt Text.Line) %if Echo Obey # 0 %end %own %byte %name len, p, limit params = params."," limit == char no(params,length(params)) Nparms = 0 p == length(params) %cycle len == p; j = 0 %cycle p == p ++ 1; j = j + 1 %repeat %until p = ',' len = j - 1 Nparms = Nparms + 1 Parm_Parm(Nparms) == string(addr(len)) %repeat %until p == limit old command == in stream(0) in stream(0)== null FD {Must clear INSTREAM(0), or OPENIN will return the FD pointed at by {OLD COMMAND to the free list when it calls CLOSE IN(0) Open in (0,from) old report == out stream(0) out stream(0)== null FD {for output must save half-written buffer in file..} FD == out stream(0) %if FD_key # 0 %start {forget about NULL:, T:} Write block (FD_key, FD_Bn+1, addr(FD_buf)) %finish Open out (0,to) Current Segs = Current Segs&(~Work Segs) Work Segs = 0 %cycle Select input (0); Select output (0) Unload(Base Load) Tlib_Name = "" Unstack Conts(1) Tidy Segs Console Int = "" Terminal Mode(0) %if TT Mode # 0 Break output Get Line %until Line # "" DoIt (Line) Show Elapsed %if Options&Opt Monitor # 0 %repeat %end %end %of %file ˙ stream(0) in stream(0)== null FD {Must clear INSTREAM(0), or OPENIN will return the FD pointed at by {OLD COMMAND to the free list when it calls CLOSE IN(0) Open in (0,from) old report == out stream(0) out stream(0)== null FD {for output must save half-written buffer in file..} FD == out stream(0) %if FD_key # 0 %start {forget about NULL:, T:} Write block (FD_key, FD_Bn+1, addr(FD_buf)) %finish Open out (0,to) Current Segs = Current Segs&(~Work Segs) Work Segs = 0 %cycle Select input (0); Select output (0) Unload(Base Load) Tlib_Name = "" Unstack Conts(1) Tidy Segs Console Int = "" Terminal Mode(0) %if TT Mode # 0 Break output get line (line) %until line # "" DoIt (line) %repeat %end %end %of %file t %start console("No room for definition of ".old) %return %finish string(Alias Limit) = old Alias Limit = Alias Limit+lo+1 string(Alias Limit) = new Alias Limit = Alias Limit+ln+1 %end %externalroutine ALIAS(%string(*)%name old) old = newp %if found(old) %end %routine get sym sym = NL %and sym type = 5 %and %return %if inp = length(line) inp = inp + 1 sym = char no(line,inp) sym type = type(sym) %end %routine stream (%string(31)%name st) st = "" %while sym type <= 4 %cycle st = st . to string(sym) %if sym type # 4 get sym %repeat get sym %if sym = ',' %end %external %integer %fn set streams (%record(command fm)%name command, %string(*)%name in line, %integer in pos) {Callable from %external routines playing a %return %if Places <= 0 S = S."." %while Places > 0 %cycle Places = Places-1 R = Fracpt(R)*10 S = S.Tostri˙ng(Intpt(R)+'0') %repeat %end %externalstring(64)%fn FtoS(%real r, %integer p) %string(64) S = "" %integer Exp, Sym P = 7 %if P > 7 %if R < 0 %then Sym = '-' %and R = -R %c %else Sym = ' ' %if R = 0 %start Exp = -99 %else Exp = 0 Exp = Exp+1 %and R = R/10 %while R >= 10 Exp = Exp-1 %and R = R*10 %while R < 1 %finish Round(R, P) Exp = Exp+1 %and R = R-1 %if R >= 10 S = S.Tostring(Intpt(R)+'0') Fraction(R, P, S) S = S."@".ItoS(Exp, 0) %result = S %end %externalroutine PrintFl(%real R, %integer Places) Printstring(Ftos(R, Places)) %end %externalstring(63)%fn RtoS(%real R, %integer A, B) %integer Before %real Rm %string(63) S = "" %constinteger Max Int = (-1) >> 1 A = 63-8 %if A > 63-8 B = 7 %if B > 7 Round(R, B) Rm = |R| %result = FtoS(R, A+B) %if Rm > Max Int Before = Intpt(R) %if Before = 0 %and r < 0 %start %while A > 0 %cycle A = A-1 S = S." " %repeat S = S."-0" %else S = ItoS(Before, A) %finish Fraction(Rm, B, S) %result = S %end %externalroutine Print(%real R, %integer B, A) Printstring(RtoS(R, B, A)) %end %externalstring(8)%fn XTOS(%integer n, p) %string(8) s = "" %integer k p = 8 %if p > 8 N = N<< ( 4*(8-P) ) %cycle k = n>>28&15; n = n<<4 %if k > 9 %then k = k-10+'A' %else k = k+'0' s = s.tostring(k) p = p-1 %result = s %if p <= 0 %repeat %end %externalroutine PHEX(%integer n, p) printstring(XTOS(n, p)) %end %externalroutine READ(%name NN) %string(255) st %integer sign, n, len, adr, type, s, base, Flag %real r, exp, f %constinteger integers=1, reals=2, strings=3, records=4, bytes=5, shorts=6, long reals=7 %switch TP(integers:longreals) len = size of(NN); adr = addr(NN) len = adr>>24+1 %if len = 0 type = type of(NN) %unless integers <= type <= longreals %and type # records %start TP(records): %signal 5,5,type %finish skip symbol %while next symbol = ' ' %or next symbol = NL %if type = strings %start st = "" %cycle s = next symbol %exit %if s = ' ' %or s = NL st = st.tostring(s) skip symbol %repeat %signal 1,3 %if len <= length(st) string(adr) = st %return %finish ! read a number sign = 0; Base = 10 sign = readsymbol %if next symbol = '-' %or next symbol = '+' %cycle n = 0; Flag = 0 %cycle s = next symbol %if '0' <= s <= '9' %start s = s-'0' %else %if 'A' <= S&95 <= 'Z' s = s&95-'A'+10 %finish %else %exit %exit %if s >= Base Flag = 1 skip symbol n = n*Base + s s = next symbol %repeat %exit %if S # '_' %or N = 0 Base = N skipsymbol %repeat r = n %if s = '.' %and (type = reals %or type = longreals) %start F = 0 Exp = 10; skip symbol %cycle s = next symbol %exit %unless '0' <= s <= '9' Flag = 1 f = f + (s-'0')/Exp Exp = Exp*10 skip symbol %repeat R = R+F %finish %if sign = '-' %start n = -n; r = -r %finish %signal 3,1,s %if Flag = 0 -> TP(type) TP(integers): integer(adr) = n; -> RETURN TP(shorts): %signal 1,1,n %unless x'FFFF8000' <= n <= x'00007FFF' shortinteger(adr) = n; -> RETURN TP(bytes): %s