Trailing-Edge
-
PDP-10 Archives
-
BB-J941D-BB
-
cvt10.sno
There are 7 other files named cvt10.sno in the archive. Click here to see a list.
* SITBOL PROGRAM TO CONVERT BLISS-10 TO BLISS-36C
*
* REVISION HISTORY
*
* 11-JULY-77 AL %REMAINDING BUG SHOULD BE 'REMAINING'
*
* 11-JULY-77 AL 'ABS' ISN'T A BLISS-10 SPECIFIC FUNCTION
*
* 12-JULY-77 PD NOVALUE REPLACED BY %INFORM.
*
* 18-JULY-77 DL ADD BLISS10_REGS, SIX12->NULL NOT DEBUG
*
* 20-JULY-77 DL CODED <BIND STRUC VAR = NOT PLIT, ... ;>
* CHANGES TO PATTERNS, FASTER NOW
* MODULE HEADER SAYS LANGUAGE, B10_REGS
*
* 21-JULY-77 DL ADDED STACKLOCAL
* FIXED GLOBAL BIND AND ROUTINE
* RESTRUCTURED #NUMBER TRANSFORMATION
*
* 22-JULY-77 DL FIXED INFINITE LOOP, ADDED CODE TO
* NOT PUT %STRING ON %CHAR UNLESS NEEDED.
* NSET -> SET EVEN ON SELECT LINE.
*
* 29-AUG-77 DL TIGHTENED UP CASE AND SELECT SO THEY
* CAN BETTER HANDLE PROGRAM LABELS IN
* TERMS OF INDENTING AND IN NOT GETTING
* THEM CONFUSED WITH CASE & SELECT LABELS.
*
* 8-MAR-78 DL FIXED MACROS SO MACRO ON THE SAME LINE
* AS ONE OF SEVERAL DEFS WORKS RIGHT.
*
* 9-MAR-78 DL ENABLED NDECS TO HAVE INITIAL ATTRIBUTES
*
* 19-MAY-78 DL GIVE A WARNING ABOUT STRUCTURE DECLARATIONS
*
* 22-MAY-78 DL PUT PARENS AROUND PLIT ITEM IF NEEDED
*
* 24-MAY-78 DL HACK TO FIX SELECT LABELS ON QUOTED STRINGS
*
* END OF REVISION HISTORY
*
*
&DUMP = 1
&ANCHOR = 1
&TRIM = 1
CVTVERSION = '24(5)'
* PATTERNS TO MATCH AND SAVE THE END-OF-LINE CHARS
* LINES ARE READ IN WITH EOL CHARS ON THEM.
LF = ASCII(12); CR = ASCII(15)
FF = ASCII(14); TABCH = ASCII(11)
TCC = SPAN(CR LF FF) . EOL
CRLF = CR LF
* OUTPUT FUNCTIONS AND STORAGE MECHANISMS
* QUEUES AND STACKS ARE MAINTAINED BY THE FUNCTIONS BELOW
DEFINE('QUEUE(QNAME,QVAL)CURRENT')
DEFINE('UNQUEUE(QNAME)')
DEFINE('PUSH(SNAME,SVAL)')
DEFINE('POP(SNAME)')
DATA('CELL(CAR,CDR)')
* INITIAL AND FINAL CALLS TO THESE STORAGE MECHANISMS CREATE
* AND DELETE THEM RESPECTIVELY. CELL IS THE BASIC DATA ITEM
* SOME DEFINITIONS:
LC = 'abcdefghijklmnopqrstuvwxyz'
UC = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
BLANKS = ' ' TABCH
DIGITS = '0123456789'
NUMBER = SPAN(DIGITS)
* 'SPANBLK' MATCHES WHITE SPACES BUT MAY NOT BE NULL
SPANBLK = SPAN(BLANKS)
SPANBLKN = SPANBLK ! NULL
ALL.BLANK = POS(0) SPANBLK RPOS(0)
SPACE8 = DUPL(' ',8)
SPACE4 = DUPL(' ',4)
DIMEN = '[' ARB ']' ! NULL
* BLISS-10 IDENTIFIER IS 'NAME'
* 'COMPLX.NAME' MATCHES NAME1:NAME2:...:NAMEN
NAME = ANY(UC) SPAN(UC DIGITS) ! ANY(UC)
COMPLX.NAME = ANY(UC) BREAK(',;[=')
SPEC.CHAR = '.%$'
QUOTES = ANY('"' "'") . QUOCH
EXTN.CH = SPAN(UC LC SPEC.CHAR)
SP.IDENT = EXTN.CH SPAN(UC LC DIGITS SPEC.CHAR) ! EXTN.CH
* 'SP.IDENT' MATCHES BLISS-10 IDENTIFIERS THAT FOLLOW '?'
* FOR FINDING <NAME>[...]<...>. ONCE FOUND, THIS
* PHRASE IS CHANGED TO (<NAME>[...])<...> (SEE DOC)
POINTNAME = (NAME '[' BREAK(']') ']') . STRCREF
+ ('<' BREAK('>') '>') . FLDREF
* TRANSFORMATION PATTERNS
* TO CONVERT CONTROL CHARS ?M -> %CHAR(13)
DEFINE('FORMQ(CTRLCH)')
NEXT.CH = LEN(1) . NEXTCH REM . LINE
QMARKS = BREAK('?') . QS1 '?' LEN(1) . CTRLCH REM . QSTR
* TO MAP "X" -> %C'X' AND TO WARN ON LONGER STRINGS
SINGLE.CHAR = LEN(1) RPOS(0) ! '""' RPOS(0)
+ ! '?' LEN(1) . CTRLCH RPOS(0) ! RPOS(0)
* KEYWORD MATCHING AND SUBSTITUTIONS
* (SEE FORMAT AT BOTTOM)
KEYWORD = 'ASCII' ! 'ASCIZ' ! 'RADIX50'
+ ! 'VREG' ! 'SIXBIT' ! 'STRUCTURE'
+ ! 'SCAN' ! 'REPLACE' ! 'COPY' ! 'INCP'
+ ! 'FIRSTONE' ! 'OFFSET' ! 'NOVALUE'
+ ! 'EXIT' ! 'GLOBALLY' ! 'INDEXES' ! 'NAMES'
LTERM = NOTANY(UC DIGITS)
NUM.KW = 17
WARNING.MES = '%(**WARNING**BLISS10**)%'
RTERM = TABLE(NUM.KW)
NEW.KW = TABLE(NUM.KW)
NEW.KW<'NOVALUE'> = "%INFORM('NOVALUE')"
RTERM<'NOVALUE'> = LTERM
NEW.KW<'ASCII'> = '%ASCII'; RTERM<'ASCII'> = LTERM
NEW.KW<'ASCIZ'> = '%ASCIZ'; RTERM<'ASCIZ'> = LTERM
NEW.KW<'RADIX50'> = '%RAD50_10'; RTERM<'RADIX50'> = LTERM
NEW.KW<'SIXBIT'> = '%SIXBIT'; RTERM<'SIXBIT'> = LTERM
NEW.KW<'VREG'> = 'VREG' WARNING.MES
RTERM<'VREG'> = LTERM ! RPOS(0)
NEW.KW<'SCAN'> = WARNING.MES 'SCAN'
RTERM<'SCAN'> = ANY('NI') LTERM
NEW.KW<'REPLACE'> = WARNING.MES 'REPLACE'
RTERM<'REPLACE'> = ANY('NI') LTERM
NEW.KW<'COPY'> = WARNING.MES 'COPY'
RTERM<'COPY'> = ANY('NI') ANY('NI') LTERM
NEW.KW<'INCP'> = WARNING.MES 'INCP'
RTERM<'INCP'> = LTERM
NEW.KW<'FIRSTONE'> = WARNING.MES 'FIRSTONE'
RTERM<'FIRSTONE'> = LTERM
NEW.KW<'OFFSET'> = WARNING.MES 'OFFSET'
RTERM<'OFFSET'> = LTERM
NEW.KW<'EXIT'> = WARNING.MES 'EXIT'
RTERM<'EXIT'> = ('CASE' ! 'COMPOUND' ! 'COMP' ! 'CONDIT'
+ ! 'COND' ! 'SELECT' ! 'SET' ! NULL) (LTERM ! RPOS(0))
NEW.KW<'GLOBALLY'> = WARNING.MES 'GLOBALLY'
RTERM<'GLOBALLY'> = LTERM ! RPOS(0)
NEW.KW<'INDEXES'> = WARNING.MES 'INDEXES'
RTERM<'INDEXES'> = LTERM ! RPOS(0)
NEW.KW<'NAMES'> = WARNING.MES 'NAMES'
RTERM<'NAMES'> = LTERM ! RPOS(0)
NEW.KW<'STRUCTURE'> =
+ 'STRUCTURE %(**WARNING**MUST BE HAND TRANSLATED**)%'
RTERM<'STRUCTURE'> = LTERM ! RPOS(0)
* PATTERN TO SEE IF THERE IS A KEYWORD ON THIS LINE
KEYSCAN = (POS(0) ! ARB LTERM) . PART1
+ KEYWORD $ KW (*RTERM<KW> ! RPOS(0)) . PART2
* <LTERM><KEYWORD><RTERM> TRANSFORMS TO
* <LTERM><NEW KEYWORD><RTERM>
OCTSCAN = (BREAK('#') ! NULL) . PART1 '#' NUMBER . PART2
* DECLARATION PATTERNS AND FORMAT DEFINITIONS
* NORMAL DECLARATION REVERSAL PATTERNS
* REVDCL IS THE MAIN MULTILINE DECLARATION REVERSER
* GRDDCL IS THE RECURSIVE KERNAL OF REVDCL (FOR 1 LINE)
DEFINE('REVDCL(SEGMENT)')
DEFINE('GRDDCL(SECTION,START.SP)NEWDEC')
* FOR SPLITTING UP 'COMPLX.NAME'S
SPLIT.NAME = NAME . ANAME (':' ! RPOS(0))
* SOME NDECS
DECNAME = 'OWN' ! 'GLOBAL' ! 'LOCAL' ! 'EXTERNAL'
+ ! 'REGISTER' ! 'MAP' ! 'STACKLOCAL'
DECLARATION = (POS(0) ! ARB LTERM) . PREDEC
+ DECNAME . CURRENT.DEC (SPANBLK REM ! RPOS(0)) . POSTDEC
* PATTERN TO DECOMPOSE NDECS
INIT.PAT = ( '=' $ TRY2.INIT SPANBLKN ( '(' (BREAK('(')
+ ABORT ! (BREAK(')') . INIT ')') ! ABORT)
+ ! NULL BREAK(',;') . INIT
+ ! ABORT )) ! NULL . INIT
GTR.PAT = ((( SPANBLK ! POS(0)) 'GLOBAL ROUTINE') . PART1
+ SPANBLK NAME . PART2
+ SPANBLK (NAME BREAK('=')) . PART3)
PARSE.SEC1 = (SPANBLK ! POS(0)) . PRETERM
+ (NAME . ATTRB SPANBLK ! NULL . ATTRB)
+ COMPLX.NAME . CNAME SPANBLKN DIMEN . BOUNDS
+ SPANBLKN
PARSE.SEC2 = SPANBLKN ANY(',;') . TERMINATOR REM . POSTTERM
PARSE.DEC = PARSE.SEC1 INIT.PAT PARSE.SEC2
PART.PARSE = PARSE.SEC1 '=' SPANBLKN (('('
+ REM) . POSTTERM ! NULL . POSTTERM RPOS(0))
* REQUIRE FILE QUOTING (IF NOT QUOTED)
DEFINE('REQDCL(SEGMENT)')
REQDEC = (POS(0) ! ARB LTERM) . PREDEC 'REQUIRE'
+ SPANBLK . POSTDEC ("'" ABORT ! ARB . FILENAME)
+ (';' REM) . TERMINATOR
* ROUTINE PRODUCES NEXT LOGICAL TAB AFTER TPSTR
DEFINE('TABPOS(TPSTR)NUM.SP')
* ROUTINE MAKES TABS .GTE. TPSTR, IE <TAB> -> <TAB>
DEFINE('TABTO(TPSTR)NUM.SP')
* TABS TO NEXT <LT> AFTER TPSTR, BUT PRESERVES TPSTR
DEFINE('TABWITH(TPSTR)NUM.SP')
* ROUTINE PRODUCES EXACT TABS AND SPACES FROM MTSTR
DEFINE('MAKTAB(MTSTR)NUM.SP')
* ROUTINE TO FIGURE OUT ACTUAL POSITION
DEFINE('FIGR.SP(BASE)CHAR1')
* BIND VECTOR PLITS EXCHANGING
DEFINE('BNDDCL(SEGMENT)')
DEFINE('BNDPLT(SECTION)')
* PATTERN TO RECOGNIZE PLITS
PLTDEC = (SPANBLK ! POS(0)) . PRETERM
+ (NAME . ATTRB SPANBLK ! NULL . ATTRB) NAME . VNAME
+ (SPANBLKN '=' (SPANBLKN
+ ('PLIT' ! 'UPLIT' ! NULL) . PLIT.TYPE) REM) . POSTTERM
BNDDEC = (POS(0) ! ARB LTERM) . PREDEC 'BIND'
+ (SPANBLK REM ! RPOS(0)) . POSTDEC
* PATTERNS TO FIND THE END OF BIND DECLARATIONS
PLTEND = (BREAK(';') ! NULL) . PRESTOP ';' REM . POSTSTOP
OTHREND = ANY(',;') . STOPPER (SPANBLKN RPOS(0)) . POSTSTOP
* PUT PARENS ON PLITS: PLIT 'ABC' -> PLIT ('ABC')
* ABORT IF ALREADY HAS PARENS
NOPAREN.PLIT =
+ ((ARB LTERM ! NULL) ('PLIT' ! 'UPLIT') SPANBLKN) . PLITPART
+ ('(' ABORT ! ARB RPOS(0)) . OTHERPART
* PATTERNS AND DEFS FOR MACHOPS AND MODULE HEADERS, SUMMARY
* MACHOPS -> MACROS WITH BUILTIN MACHOP
DEFINE('MHOPDCL(SEGMENT)')
DEFINE('MACMSH(SECTION,START.SP)NEWDEC')
MSHDEC = (POS(0) ! ARB LTERM) . PREDEC 'MACHOP'
+ (SPANBLK REM ! RPOS(0)) . POSTDEC
MHOP.SPLIT = (SPANBLK ! POS(0)) NAME . MSH.NAME
+ SPANBLKN '=' SPANBLKN BREAK(',;') . MSH.CODE
+ LEN(1) . TERMINATOR REM . POSTTERM
* MODULE HEADER GETS %BLISS36(BLISS10_REG %QUOTE,)
* MODULE HEADER SIX12 -> NULL
DEFINE('MODDCL(SEGMENT)')
MODDEC = (BREAK('(') '(') . PREDEC ARB . MIDDEC
+ (')' SPANBLKN '=' SPANBLKN ('BEGIN' ! NULL)
+ SPANBLKN RPOS(0)) . POSTDEC
MH.SIX12 = SPANBLKN 'TIMER' SPANBLKN '=' SPANBLKN
+ 'EXTERNAL(SIX12)' SPANBLKN
MH.INFO = '%BLISS36(BLISS10_REGS %QUOTE,)' CRLF
+ TABCH 'LANGUAGE(%BLISS36(BLISS36)' CRLF
+ TABCH '%BLISS32(BLISS32)' CRLF
+ TABCH '%BLISS16(BLISS16))'
* MACRO $ -> %QUOTE %QUOTE ... %, MACRO.DEPTH - 1 %QUOTE'S
MACRO.TERM = (POS(0) NULL ! LEN(1)) . CH1 '$'
+ ((BREAK(',;') ! NULL) ANY(',;') . CH2
+ ! SPANBLKN NULL . CH2 RPOS(0))
MACRO.NEW = (POS(0) ! LTERM) 'MACRO' BREAK('$')
* NOTE: KLUDGE SO THAT ONE LINE MACROS WORK RIGHT
* BEFORE DECLARATION MATCHING A CHECK IS DONE TO
* SEE IF A MACRO IS COMING, SO MACRO DEPTH CAN
* BE TEMP. INCREMENTED VIA MXTRA
MXTRA = 0
* SUMMARY OF DECLARATIONS
ALL.TRNS = 'GLOBAL ROUTINE' ! 'GLOBAL BIND'
+ ! DECNAME ! 'REQUIRE' ! 'BIND' ! 'SWITCHES' ! 'FORWARD'
+ ! 'MACHOP' ! 'CASE' ! 'SELECT' ! 'MODULE' ! 'MACRO'
KNOWN.TRNS = (POS(0) ! ARB LTERM)
+ ALL.TRNS . DECKEY (SPANBLK ! RPOS(0))
* ABOVE ARE THE KEY PATTERNS TO THE OPERATION OF CVT10
* TABLE OF TRANSFORMS
TRNTAB = TABLE(16)
TRNTAB<'GLOBAL'> = 'NDEC'; TRNTAB<'OWN'> = 'NDEC'
TRNTAB<'LOCAL'> = 'NDEC'; TRNTAB<'EXTERNAL'> = 'NDEC'
TRNTAB<'MAP'> = 'NDEC'; TRNTAB<'FORWARD'> = 'FDEC'
TRNTAB<'REGISTER'> = 'NDEC'; TRNTAB<'REQUIRE'> = 'RDEC'
TRNTAB<'BIND'> = 'BDEC'; TRNTAB<'SWITCHES'> = 'SDEC'
TRNTAB<'MACHOP'> = 'MDEC'; TRNTAB<'CASE'> = 'CASE'
TRNTAB<'SELECT'> = 'SEL'; TRNTAB<'MODULE'> = 'MOD'
TRNTAB<'MACRO'> = 'MCRO'; TRNTAB<'STACKLOCAL'> = 'NDEC'
TRNTAB<'GLOBAL BIND'> = 'BDEC'
TRNTAB<'GLOBAL ROUTINE'> = 'GTR'
* NDECS ARE NORMAL DECLARATIONS, NOP IS NO-OPERATION TO DO
* PATTERNS TO CONTROL THE CVTCOM AND CVTTEXT FEATURES(SEE DOC)
CVTCOMP = SPANBLKN ('CVTCOM' ! 'cvtcom')
CVTTEXTP = SPANBLKN ('CVTTEXT' ! 'cvttext')
MOCTVCP = SPANBLKN '!' SPANBLKN ('MOCTVC' ! 'moctvc')
TXETTVCP = SPANBLKN '!' SPANBLKN ('TXETTVC' ! 'txettvc')
* PATTERNS FOR CASE STATEMENTS AND SELECTS
STOP.SET = ARB . PRESTOP ((NULL . SPEC.TERM ANY('();') . STOPPER REM . POSTSTOP)
+ ! ((POS(0) ! LTERM) . SPEC.TERM
+ ('BEGIN' ! 'END' ! 'CASE' ! 'OF' ! 'SET' ! 'TES') . STOPPER
+ (LTERM REM ! RPOS(0)) . POSTSTOP))
TOP.BOUND = '<$$$' NUMBER . CASE.NUM '$$$>'
HIGH.RANGE = ARRAY('64')
JUST.COMMENT = (SPANBLK ! POS(0)) '!'
DEFINE('CASEXP(SEGMENT)BUILD.STR')
DEFINE('PREFIX(SEGMENT)PRESTUFF,POSTSTUFF')
DEFINE('UNFIX(SEGMENT)PRESTUFF,POSTSTUFF')
* CASEXP WILL STACK A CASE ENVIRONMENT IF ANOTHER
* CASE IS ENCOUNTERED. THE STACKS ARE:
* PC.:PAREN.COUNT, EC.:EXP.COUNT, CC.:CASE.NO
* SEE ALSO THE CASE TRANSFORM SECTION
* PATTERNS AND DEFS FOR SELECTS
SEL.STOP.SET = (POS(0) ! ARB) . PRESTOP
+ (((SPANBLK '[' BREAK(']') ']' ABORT ! ARB) . MIDSTOP
+ ':' . STOPPER REM . POSTSTOP)
+ ! ((LTERM ! POS(0)) . MIDSTOP
+ ('SELECT' ! 'NSET' ! 'TESN') . STOPPER
+ ((LTERM ! RPOS(0)) REM) . POSTSTOP))
SEL.COLON = ((SPANBLKN ! POS(0)) . PRESTOP
+ (BREAK(' ' TABCH ':' CRLF) ! NULL) . EXPTERM
+ SPANBLKN (':' ! CRLF ABORT)) . MIDSTOP REM . POSTSTOP
* DON'T LOOK BEYOND A CRLF SO WON'T SEE DECLARE ATTRIBUTES ':'
BADCODE.NSET = (ARB LTERM) . PRESTOP 'NSET' REM . POSTSTOP
DEFINE('SELEXP(SEGMENT)')
DEFINE('AT.END(BASE,ENDER)CHAR.CNT')
* HACK PATTERN TO TRY TO PUT [] AROUND QUOTED STRINGS IN NEEDED.
* OPERATES ON THE OUTSTR BEING BUILT AFTER!!! OUTSEC IS CALLED.
HACK.EXPSET = SPANBLKN REM . EXPTERM
* MAIN ENVIRONMENTS FOR PATTERN MATCHING
N = BREAK("!%?" "'" '"') . STRING LEN(1) . BRKCH REM . LINE
C = ARB . STRING RPOS(0)
P = BREAK('%') . STRING LEN(1) . BRKCH REM . LINE
Q1 = BREAK("'") . STRING LEN(1) . BRKCH REM . LINE
Q2 = BREAK('"') . STRING LEN(1) . BRKCH REM . LINE
L = SP.IDENT . STRING REM . LINE
* MATCH=>LEAVE STATE NOW
* N:NORMAL, C:COMMENT, P:PERCENT COMMENT
* Q:QUOTED STRING (POSSIBLE DOUBLE QUOTES)
* L:LITERAL NAME LIKE ?J..DAT --> %NAME('J..DAT')
* ENV.SX: SUCCEEDED IN LEAVING STATE X
* ENV.FX: FAILED TO LEAVE STATE X
* ENV.EX: ENTERED STATE X WITH NULL LINE LEFT
STATAB = TABLE(5)
STATAB<'%'> = 'P'; STATAB<"'"> = 'Q1'
STATAB<'?'> = 'L'; STATAB<'!'> = 'C'
STATAB<'"'> = 'Q2'
BRKTAB = TABLE(5)
BRKTAB<'%'> = '%('; BRKTAB<"'"> = ''
BRKTAB<'!'> = '!'; BRKTAB<'?'> = ''
BRKTAB<'"'> = ''
* SPECIAL ELIMINATION OF <0,0> AND <0,36>
KILL.POINTY = '<0,' ('0' ! '36') '>'
* SPECIAL DEBUGGING AIDS
:(FILBEG)
OUTPUT(.TTYOUT,'TTY:',)
INPUT(.TTYIN,'TTY:',)
CK.LBL = 'MTV' ! 'MTL' ! 'LOOK' ! 'NODEBUG'
CK. TTYOUT = 'COMMANDS: MTV(MATCH VARIABLE), MTL(MATCH LITERAL),'
+ ' LOOK, NODEBUG'
CK TTYOUT = 'COMMAND>'
COMMAND = TTYIN :F(XEND)
COMMAND CK.LBL :S($('CK.' COMMAND))F(CK.)
CK.MTV TTYOUT = 'VARIBLE>'
STRG = TTYIN
STRG = $STRG :(CK.MT)
CK.MTL TTYOUT = 'LITERAL>'
STRG = TTYIN
CK.MT TTYOUT = 'PATTERN>'
PAT0 = TTYIN
STRG $PAT0 :S(CK)
TTYOUT = 'FAILED' :(CK)
CK.LOOK TTYOUT = 'VARIBLE>'
TTYOUT = '/' $TTYIN '/' :(CK)
CK.NODEBUG :(FILGET)
* SETUP I/O FILES, EXIT TO ALLOW CORE IMAGE TO BE SAVED
FILBEG COMPILED = EQ(COMPILED,0) 1 :F(FILCMP)
EXIT(0)
FILCMP OUTPUT(.TTYOUT,'TTY:',)
INPUT(.TTYIN,'TTY:',)
FILGET TTYOUT = 'INPUT FILE NAMES SEPARATED BY SPACES'
FIN.NAMES = TTYIN :F(XXXEND)
FIN.NAMES = IDENT(FIN.NAMES) 'TTY:'
TTYOUT = 'OUTPUT FILE NAMES'
FOUT.NAMES = TTYIN :F(XXXEND)
FOUT.NAMES = IDENT(FOUT.NAMES) 'TTY:'
FILES.IN = ARRAY(16)
FILES.OUT = ARRAY(16)
SPLIT.FILE = (RPOS(0) ABORT) ! ((SPANBLK ! POS(0))
+ ARB . FNAME (SPANBLK ! RPOS(0)))
FILE.NUM = 0
NUM.FILES = 0
FILBRK FIN.NAMES SPLIT.FILE = '' :F(FILDON)
FILE(FNAME) :F(FILPUNT)
NUM.FILES = NUM.FILES + 1
FILES.IN<NUM.FILES> = FNAME :(FILBRK)
FILPUNT TTYOUT = '%CVT UNKNOWN FILE ' FNAME :(FILGET)
FILDON FOUT.NAMES SPLIT.FILE = '' :F(FILDONE)
FILE.NUM = FILE.NUM + 1
FILES.OUT<FILE.NUM> = FNAME :(FILDON)
FILDONE FILE.NUM = 0 :(MAIN)
* MAIN PROGRAM ACTS LIKE A FINITE-STATE MACHINE
MAIN STATE = 'N'
ENV = N
QSTR = ''
EQYET = ''; BNDYET = ''; LABEL = ''
HOLD = 0; CASE.NO = 0; ABS.CASE.NO = 0
SEL.DEPTH = 0; CASE.DEPTH = 0; MACRO.DEPTH = 0
CVTCOM = ''; CVTTEXT = ''; CLOSE.PLIT = ''
QUOCH = ''
FILE.NUM = FILE.NUM + 1
OUTPUT(.FILEOUT,FILES.OUT<FILE.NUM>,'T')
INPUT(.FILEIN,FILES.IN<FILE.NUM>,'T')
FILEOUT = '!' DUPL(TABCH,2) 'BLISS-10 TO BLISS-36C CONVERSION '
+ '(VERSION ' CVTVERSION ') ' DATE() CRLF CRLF
RDLOOP LINE = FILEIN :F(XEND)
&ANCHOR = 0
LINE TCC = ''
&ANCHOR = 1
OUTSTR = ''
EQ(CASE.DEPTH,0) :S(CTLOOP)
IDENT(LINE) :S(CTLOOP)
LINE = PREFIX(LINE)
CTLOOP STRING = LINE
BRKCH = ''
LINE ENV :S($('ENV.S' STATE))F($('ENV.F' STATE))
ENV.SN IDENT(LINE) :S($('ENV.E' STATAB<BRKCH>))
STATE = STATAB<BRKCH>
BRKCH QUOTES
ENV.OK BRKCH = BRKTAB<BRKCH> :(ENV.N)
ENV.FN LINE = ''
ENV.N STRING = REPLACE(STRING,'_@' LC,'=.' UC)
&ANCHOR = 0
REPCH = ''
STRING MACRO.NEW :F(FIXPER)
MXTRA = 1
MACRO.1LINE = 'TRUE'
FIXPER STRING MACRO.TERM :F(DELPNT)
REPCH = LNE(CH1,' ') ' '
REPCH = REPCH DUPL('%QUOTE ',
+ MACRO.DEPTH - 1 + MXTRA) '%' :S(FIXP0)
REPCH = '% %(**WARNING**LOOSE DOLLAR SIGN NOW %)%'
FIXP0 STRING '$' = REPCH
DIFFER(MACRO.1LINE) :S(FIXPER)
MACRO.DEPTH = LEQ(CH2,';') MACRO.DEPTH - 1 :(FIXPER)
DELPNT MXTRA = 0
DEL00 STRING KILL.POINTY = '' :S(DEL00)
POINTY STRING POINTNAME = '(' STRCREF ')' FLDREF :S(POINTY)
&ANCHOR = 1
* CHANGE PLIT 'FOOBAR' INTO PLIT ('FOOBAR')
IDENT(QUOCH) :S(DOKEYS)
STRING NOPAREN.PLIT :F(DOKEYS)
STRING = PLITPART '(' OTHERPART
CLOSE.PLIT = 'TRUE'
DOKEYS NEW.STRING = ''
NEWKWD STRING KEYSCAN = '' :F(KEYEND)
NEW.STRING = NEW.STRING PART1
+ NEW.KW<KW> PART2 :(NEWKWD)
KEYEND STRING = NEW.STRING STRING
NEW.STRING = ''
OCTKWD STRING OCTSCAN = '' :F(OCTEND)
NEW.STRING = NEW.STRING PART1 "%O'" PART2 "'" :(OCTKWD)
OCTEND STRING = NEW.STRING STRING
* TRANSFORM ROUTINE CALLS
DIFFER(TRANS.TYPE) :S($('T.' TRANS.TYPE))
STRING KNOWN.TRNS :F(NO.DO)
TRANS.TYPE = TRNTAB<DECKEY> :($('T.' TRANS.TYPE))
NO.DO STRING = NE(CASE.DEPTH,0) CASEXP(STRING)
STRING = NE(SEL.DEPTH,0) SELEXP(STRING) :(OUTSEC)
T.NDEC STRING = REVDCL(STRING) :(NO.DO)
T.RDEC STRING = REQDCL(STRING) :(NO.DO)
T.FDEC STRING ((SPANBLK ! POS(0)) 'FORWARD') . PREFRWD = PREFRWD ' ROUTINE'
TRANS.TYPE = '' :(NO.DO)
T.BDEC STRING = BNDDCL(STRING) :(NO.DO)
T.SDEC LINE = ''
STRING = ''
TRANS.TYPE = ''
EOL = LEQ(EOL,CRLF) '' :(NO.DO)
* DELETE ALL SWITCHES, LEAVES A <FF> BUT KILLS <CRLF>
T.MDEC STRING = MHOPDCL(STRING) :(NO.DO)
T.MOD TRANS.TYPE = ''
STRING = MODDCL(STRING) :(NO.DO)
T.CASE TRANS.TYPE = ''
STRING = CASEXP(STRING)
STRING = NE(SEL.DEPTH,0) SELEXP(STRING) :(OUTSEC)
T.SEL TRANS.TYPE = ''
STRING = NE(CASE.DEPTH,0) CASEXP(STRING)
STRING = SELEXP(STRING) :(OUTSEC)
T.MCRO TRANS.TYPE = ''
MACRO.1LINE = DIFFER(MACRO.1LINE) '' :F(NORMAC)
LEQ(CH2,';') :S(NO.DO)
NORMAC MACRO.DEPTH = MACRO.DEPTH + 1 :(NO.DO)
T.NOP TRANS.TYPE = '' :(NO.DO)
T.GTR TRANS.TYPE = ''
STRING GTR.PAT = PART1 ' ' PART3 ' :' TABCH PART2 ' ' :(NO.DO)
* HANDLING OF STRINGS AND COMMENTS
ENV.EC :(ENV.OK)
ENV.FC
ENV.SC LINE = ''
DIFFER(CVTCOM CVTTEXT) :S($('COM.' CVTCOM CVTTEXT))
* SEE IF THIS COMMENT SAYS TO ENTER COM OR TEXT READING
STRING CVTCOMP :F(COM1)
CVTCOM = 'COM' :(OUTSEC)
COM1 STRING CVTTEXTP :F(COM2)
CVTTEXT = 'TXT' :(OUTSEC)
COM2 STATE = 'N' :(OUTSEC)
* IN COM MODE SO COMMENT EACH LINE UNTIL MOCTVC
COM.COM STRING MOCTVCP :F(COMC)
CVTCOM = ''
STATE = 'N' :(OUTSEC)
COMC STRING = '!' TABCH STRING :(OUTSEC)
* IN TEXT MODE SO REMOVE LEADING '!' UNTIL TXETTVC
COM.TXT STRING TXETTVCP :F(COMT)
CVTTEXT = ''
STATE = 'N' :(OUTSEC)
COMT STRING (SPANBLKN . PART1 '!') = PART1 :(OUTSEC)
ENV.EP STATE = 'P' :(ENV.OK)
ENV.SP STATE = 'N'
BRKCH = ')%' :(OUTSEC)
ENV.FP LINE = '' :(OUTSEC)
ENV.EQ1
ENV.EQ2 CLOSE.PLIT = ''
QUOCH = ''
BRKCH = "' !**WARNING** DANGLING QUOTE" :(ENV.N)
ENV.SQ1
ENV.SQ2 LINE NEXT.CH :F(TRANSQ)
LINE = LNE(NEXTCH,QUOCH) NEXTCH LINE :S(TRANSQ)
QSTR = QSTR STRING QUOCH QUOCH :(CTLOOP)
TRANSQ QSTR = QSTR STRING
STATE = 'N'
LEQ(QUOCH,"'") :S(SKIPDQ)
QSTR SINGLE.CHAR :F(WARNDQ)
STRING = LEQ(QSTR,'""') "%C'" '"' "'" :S(QDONE2)
STRING = LEQ(QSTR,"'") "%C''''" :S(QDONE2)
STRING = IDENT(QSTR) "''" :S(QDONE2)
LEQ(QSTR,'?' CTRLCH) :F(NORMSC)
STRING = LEQ(CTRLCH,'0') '0 %(NULL CHAR)%' :S(QDONE2)
STRING = LEQ(CTRLCH,'1') '127 %(DELETE CHAR)%' :S(QDONE2)
STRING = LEQ(CTRLCH,'?') "%C'?'" :S(QDONE2)
CHCODE = -1
FORMQ(CTRLCH)
STRING = EQ(CHCODE,-1) "%C'" CTRLCH
+ "' -64 %(**WARNING**QUESTIONMARK)%" :S(QDONE2)
STRING = CHCODE ' %(CTRL-' CTRLCH ')%' :(QDONE2)
NORMSC STRING = "%C'" QSTR "'" :(QDONE2)
WARNDQ STRING = '"' QSTR '" %(**WARNING**DOUBLE QUOTES)%' :(QDONE2)
SKIPDQ CTRLCH = ''
NQSTR = ''
RMOVQM QS1 = ''
QSTR QMARKS :F(QDONE)
NQSTR = DIFFER(NQSTR) NQSTR ','
QS1 = DIFFER(QS1) "'" QS1 "',"
NQSTR = NQSTR QS1 FORMQ(CTRLCH) :(RMOVQM)
FORMQ FORMQ = LEQ(CTRLCH,'?') "'?'" :S(RETURN)
FORMQ = LEQ(CTRLCH,'1') '%CHAR(127)' :S(RETURN)
&ANCHOR = 0
('0' UC) (@CHCODE CTRLCH) :F(FRMBAD)
&ANCHOR = 1
FORMQ = '%CHAR(' CHCODE ')' :(RETURN)
FRMBAD FORMQ = "%CHAR(%C('" CTRLCH "')-64)"
+ "%(**WARNING**QUESTIONMARK)%" :(RETURN)
QDONE NQSTR = ?(DIFFER(QSTR) DIFFER(NQSTR)) NQSTR ",'" QSTR "'"
STRING = IDENT(NQSTR) "'" QSTR "'" :S(QDONE2)
&ANCHOR = 0
NQSTR ',' :S(QDONE1)
STRING = NQSTR :(QDONE2)
* CHECKING FOR LONE %CHAR'C', DON'T PUT %STRING AROUND IT
QDONE1 STRING = '%STRING(' NQSTR ')'
QDONE2 &ANCHOR = 1
QUOCH = ''
QSTR = ''
BRKCH = IDENT(CLOSE.PLIT) '' :S(OUTSEC)
CLOSE.PLIT = ''
BRKCH = ')' :(OUTSEC)
ENV.FQ1
ENV.FQ2 LINE = ''
QUOCH = ''
STRING = "'" STRING
STATE = 'N'
BRKCH = IDENT(CLOSE.PLIT) ' !**WARNING**MISSING QUOTE' :S(OUTSEC)
CLOSE.PLIT = ''
BRKCH = ') !**WARNING**MISSING QUOTE' :(OUTSEC)
ENV.SD STATE = DIFFER(LINE) 'Q' :S(OUTSEC)F(ENV.FQ)
ENV.FD STATE = 'N'
STRING = '' :(OUTSEC)
ENV.EL BRKCH = "? !**WARNING**ILLEGAL USE OF '?'" :(ENV.N)
ENV.SL STRING = "%NAME('" STRING "')"
STATE = 'N' :(OUTSEC)
ENV.FL STRING = " %(**WARNING**ILLEGAL '?' NAME)% ?"
STATE = 'N' :(OUTSEC)
* ROUTINES FOR TRANSLATING NORMAL DECLARATIONS
REVDCL IDENT(SEGMENT) :S(FRETURN)
DIFFER(CURRENT.DEC) :S(CTRDCL)
SEGMENT DECLARATION :S(SETDCL)
TRANS.TYPE = '' :(FRETURN)
SETDCL JUST.TABS = TABPOS(PREDEC)
NL.TABS = CRLF JUST.TABS
SP.PRENAME = JUST.TABS
SP.PRENAME = DIFFER(POSTDEC) NL.TABS
REVDCL = PREDEC CURRENT.DEC
+ GRDDCL(POSTDEC,SP.PRENAME) :S(RETURN)F(FRETURN)
CTRDCL INHIBIT.SELLBL = 'TRUE'
REVDCL = GRDDCL(SEGMENT,JUST.TABS) :S(RETURN)F(FRETURN)
GRDDCL GRDDCL = IDENT(SECTION) '' :S(RETURN)
SECTION ALL.BLANK :F(CTGRD)
GRDDCL = SECTION :(RETURN)
CTGRD TRY2.INIT = ''
TERMINATOR = ''
SECTION PARSE.DEC :S(GRDINI)
TRANS.TYPE = ''
CURRENT.DEC = ''
IDENT(TRY2.INIT) :S(FRETURN)
SECTION PART.PARSE :F(FRETURN)
INIT = DIFFER(POSTTERM) 'INITIAL ' POSTTERM :S(GRD)
INIT = 'INITIAL' :(GRD)
GRDINI IDENT(INIT) :S(GRD)
INIT = 'INITIAL(' INIT ')'
GRD ATTRB = DIFFER(ATTRB) ':' TABCH ATTRB BOUNDS :S(GRDA)
ATTRB = DIFFER(BOUNDS) ':' TABCH 'VECTOR' BOUNDS :S(GRDA)
ATTRB = DIFFER(INIT) ':' TABCH INIT :(UNANC)
GRDA ATTRB = DIFFER(INIT) ATTRB ' ' INIT
UNANC &ANCHOR = 0
RMVBLK CNAME SPANBLK = '' :S(RMVBLK)
&ANCHOR = 1
NEWDEC = ''
GRD1 CNAME SPLIT.NAME = '' :F(GRD2)
NEWDEC = DIFFER(NEWDEC) NEWDEC ',' NL.TABS
NEWDEC = NEWDEC ANAME ATTRB :(GRD1)
GRD2 NEWDEC = START.SP NEWDEC
GRDDCL = IDENT(TERMINATOR) NEWDEC :S(RETURN)
LEQ(',',TERMINATOR) :F(GRD3)
GRDDCL = NEWDEC ',' GRDDCL(POSTTERM,NL.TABS) :F(FRETURN)S(RETURN)
GRD3 CURRENT.DEC = ''
TRANS.TYPE = ''
POSTTERM ALL.BLANK ! RPOS(0) :S(GRD4)
POSTTERM SPANBLK = ''
POSTTERM = CRLF MAKTAB(PREDEC) POSTTERM
GRD4 GRDDCL = NEWDEC ';' POSTTERM :(RETURN)
* REQUIRE DECLARATION TRANSFORM
REQDCL SEGMENT REQDEC :S(REQ0)
TRANS.TYPE = '' :(FRETURN)
REQ0 POSTDEC = POSTDEC "'" FILENAME "'" TERMINATOR
REQDCL = PREDEC 'REQUIRE' POSTDEC
TRANS.TYPE = '' :(RETURN)
* TAB FORMATTING FUNCTIONS
* TABPOS POSITIONS AT THE NEXT LOGICAL TAB STOP AFTER TPSTR
TABPOS NUM.SP = FIGR.SP(TPSTR)
TABPOS = DUPL(TABCH,NUM.SP / 8)
NUM.SP = NUM.SP - (8 * (NUM.SP / 8))
TABPOS = LT(NUM.SP,4) TABPOS SPACE4 :S(RETURN)
TABPOS = TABCH TABPOS :(RETURN)
* <TAB> -> <TAB> BUT <TAB>X -> <TAB><LTAB>
TABTO NUM.SP = FIGR.SP(TPSTR)
TABTO = DUPL(TABCH,NUM.SP / 8)
NUM.SP = NUM.SP - (8 * (NUM.SP / 8))
TABTO = EQ(NUM.SP,0) TABTO :S(RETURN)
TABTO = LE(NUM.SP,4) TABTO SPACE4 :S(RETURN)
TABTO = TABCH TABTO :(RETURN)
* MAKE AN EXACT NUMBER OF TABS AND SPACES
MAKTAB NUM.SP = FIGR.SP(MTSTR)
MAKTAB = DUPL(TABCH,NUM.SP / 8)
+ DUPL(' ',NUM.SP - 8 * (NUM.SP / 8)) :(RETURN)
* AT.END FITS ENDER INTO BASE WITHOUT CHANGING THE SIZE OF BASE
* XXXXXXEEEEXXX: -> XXXXXXX[EEEE]: FOR LABELING SELECTS
AT.END CHAR.CNT = FIGR.SP(BASE)
AT.END = GT(SIZE(ENDER), CHAR.CNT) ENDER :S(RETURN)
BASE = MAKTAB(DUPL(' ',CHAR.CNT - SIZE(ENDER)))
AT.END = BASE ENDER :(RETURN)
* FIGR.SP IS USED TO FIND THE TAB POSITIONS
FIGR.SP FIGR.SP = IDENT(BASE) 0 :S(RETURN)
FIGR0 BASE LEN(1) . CHAR1 = '' :F(RETURN)
FIGR.SP = LNE(CHAR1, TABCH) FIGR.SP + 1 :S(FIGR0)
FIGR.SP = 8 + 8 * (FIGR.SP / 8) :(FIGR0)
* PREFIX PUTS EXTRA TABS ON ADDITIONAL INDEXING TEXT, CASE LABELS
PREFIX IDENT(SEGMENT) :S(FRETURN)
PREFIX = ''
SEGMENT SPANBLK . PRESTUFF REM . POSTSTUFF :F(PXLBL)
PRESTUFF = TABTO(PRESTUFF)
PX.FOOL SEGMENT JUST.COMMENT :S(PX.NLBL)
IDENT(LABEL) :S(PX.NLBL)
IDENT(POSTSTUFF) :S(PX.NLBL)
LABEL = ''
PREFIX = PREFIX TABWITH(DUPL(TABCH,CASE.DEPTH - 1) PRESTUFF
+ '[' EXP.COUNT ']:') POSTSTUFF :S(RETURN)F(FRETURN)
PX.NLBL PREFIX = PREFIX TABTO(DUPL(TABCH,CASE.DEPTH) PRESTUFF)
+ POSTSTUFF :S(RETURN)F(FRETURN)
PXLBL SEGMENT (BREAK(':') LEN(1) SPANBLKN) . PRESTUFF
+ REM . POSTSTUFF :F(PXFLBL)
PREFIX = PRESTUFF
PRESTUFF = '' :(PX.FOOL)
PXFLBL PRESTUFF = ''
POSTSTUFF = SEGMENT :(PX.FOOL)
* IF A PROGRAM LABEL EXISTS TRY TO INDENT AFTER IT
* THIS METHOD MAY NOT WORK FOR ALL CASES
* IF LABEL IS TRUE A CASE LABEL IS PUT ON THE FIRST NON-NULL AND
* NON-ALL BLANK LINE, COMMENTS SHOULDN'T GET LABELED, ONLY BODY.
UNFIX IDENT(SEGMENT) :S(FRETURN)
SEGMENT SPANBLK . PRESTUFF REM . POSTSTUFF :F(UNF0)
PRESTUFF = TABTO(PRESTUFF)
PRESTUFF = TABTO(DUPL(' ',FIGR.SP(PRESTUFF) - 8))
UNFIX = PRESTUFF POSTSTUFF :(RETURN)
UNF0 UNFIX = SEGMENT :(RETURN)
* ??UNF0 SHOULD NEVER HAPPEN??
* FORMATS THE CASE LABEL
TABWITH NUM.SP = FIGR.SP(TPSTR)
NUM.SP = NUM.SP - 8 * (NUM.SP / 8)
TABWITH = LT(NUM.SP,4) TPSTR DUPL(' ',4 - NUM.SP) :S(RETURN)
TABWITH = TPSTR TABCH :(RETURN)
* MAKE SURE THE LABEL TAKES UP EXACTLY 8 SPACES,
* BY EITHER APPENDING A PHYSICAL TAB, OR A FEW SPACES
* BIND PLIT AND UPLIT TRANSFORMS, MODULE HEADER
* CHANGES THE POSITION OF <BIND STRC VAR = PLIT (...)>
* TO <BIND VAR = PLIT (...) :STRUC> WITH DEFAULT <:VECTOR>
* RESTRICTION: <VAR STRUC = PLIT> MUST BE ON THE SAME LINE
* CHANGES <BIND STRUC VAR = OTHER> TO <BIND VAR = OTHER: STRUC>
* <<<NOTE>>> AS WRITTEN, ONLY BIND ...; <SEMICOLON> IS CONVERTED
BNDDCL DIFFER(BNDYET) :S(CTBND)
SEGMENT BNDDEC :F(BADBND)
BNDYET = 'TRUE'
BNDDCL = PREDEC 'BIND' BNDPLT(POSTDEC) :S(RETURN)F(FRETURN)
BADBND TRANS.TYPE = '' :(FRETURN)
CTBND BNDDCL = BNDPLT(SEGMENT) :S(RETURN)F(FRETURN)
BNDPLT BNDPLT = IDENT(SECTION) '' :S(RETURN)
SECTION ALL.BLANK :F(BNDP1)
BNDPLT = SECTION :(RETURN)
BNDP1 DIFFER(EQYET) :S(CTPLT)
SECTION PLTDEC :S(SETBND)
TRANS.TYPE = ''
BNDYET = '' :(FRETURN)
SETBND IDENT(PLIT.TYPE) :S(BNDOTHR)
EQYET = 'TRUE'
* ONLY ONE PLIT PER BIND, BUT MANY REGULAR DECS ARE OKAY
ATTRB = IDENT(ATTRB) 'VECTOR'
ATTRB = TABCH ':' ATTRB :(BNDMORE)
BNDOTHR ATTRB = DIFFER(ATTRB) ':' TABCH ATTRB
&ANCHOR = 0
POSTTERM OTHREND = ATTRB STOPPER POSTSTOP :S(BNDOTR0)
&ANCHOR = 1
TRANS.TYPE = ''; BNDYET = '' :(FRETURN)
* PUNTING DUE TO NO DELIMITER FOUND AFTER BIND DEC
BNDOTR0 &ANCHOR = 1
BNDPLT = PRETERM VNAME POSTTERM
LEQ(STOPPER,',') :S(RETURN)
TRANS.TYPE = ''; BNDYET = '' :(RETURN)
BNDMORE BNDPLT = PRETERM VNAME BNDPLT(POSTTERM) :(RETURN)
CTPLT SECTION PLTEND :S(ENDPLT)
BNDPLT = SECTION :(RETURN)
ENDPLT TRANS.TYPE = ''; BNDYET = ''; EQYET = ''
POSTSTOP ALL.BLANK ! RPOS(0) :S(ENDPLT0)
POSTSTOP SPANBLK = ''
POSTSTOP = CRLF MAKTAB(PREDEC) POSTSTOP
ENDPLT0 INHIBIT.SELLBL = 'TRUE'
BNDPLT = PRESTOP ATTRB ';' POSTSTOP :(RETURN)
* MODULE HEADER TRANSFORM, SIX12 -> NULL, INSERT BLISS10_REGS
* PUT A %QUOTE , IFF MORE OPTIONS FOLLOW
MODDCL SEGMENT MODDEC :F(MODMTY)
&ANCHOR = 0
MIDDEC MH.SIX12 ',' = '' :S(MODCNT)
MIDDEC ',' MH.SIX12 = '' :S(MODCNT)
MIDDEC MH.SIX12 = ''
MODCNT &ANCHOR = 1
MIDDEC ALL.BLANK = ''
MIDDEC = IDENT(MIDDEC) MH.INFO :S(MODDONE)
MIDDEC SPANBLK = ''
MIDDEC = MH.INFO ', ' MIDDEC :(MODDONE)
MODMTY &ANCHOR = 0
SEGMENT '=' = '(' MH.INFO ') ='
&ANCHOR = 1
MODDCL = SEGMENT :(RETURN)
MODDONE MODDCL = PREDEC MIDDEC POSTDEC :(RETURN)
* ROUTINES FOR TRANSLATING MACHOPS INTO MACROS
MHOPDCL IDENT(SEGMENT) :S(FRETURN)
DIFFER(MSHYET) :S(CTMSH)
SEGMENT MSHDEC :S(SETMSH)
TRANS.TYPE = '' :(FRETURN)
SETMSH MACDEF = TABTO(PREDEC)
JUST.TABS = TABPOS(MACDEF)
MACDEF = MACDEF 'MACRO'
NL.TABS = CRLF JUST.TABS
SP.PRENAME = JUST.TABS
SP.PRENAME = DIFFER(POSTDEC) NL.TABS
PERQUO = ''
PERQUO = DUPL('%QUOTE ',MACRO.DEPTH)
MSHYET = 'TRUE'
MHOPDCL = PREDEC 'BUILTIN MACHOP;' CRLF CRLF MACDEF
+ MACMSH(POSTDEC,SP.PRENAME) :S(RETURN)F(FRETURN)
CTMSH MHOPDCL = MACMSH(SEGMENT,JUST.TABS) :S(RETURN)F(FRETURN)
MACMSH MACMSH = IDENT(SECTION) '' :S(RETURN)
SECTION ALL.BLANK :F(CTMMSH)
MACMSH = SECTION :(RETURN)
CTMMSH SECTION MHOP.SPLIT :S(MSH0)
TRANS.TYPE = ''
MSHYET = '' :(FRETURN)
MSH0 NEWDEC = MSH.NAME '[] = MACHOP(' MSH.CODE ', '
+ PERQUO '%REMAINING) ' PERQUO '%'
NEWDEC = START.SP NEWDEC
LEQ(';',TERMINATOR) :S(MSH1)
MACMSH = NEWDEC ',' MACMSH(POSTTERM,NL.TABS) :F(FRETURN)S(RETURN)
MSH1 MSHYET = ''
TRANS.TYPE = ''
POSTTERM ALL.BLANK ! RPOS(0) :S(MSH2)
POSTTERM SPANBLK = ''
POSTTERM = CRLF MAKTAB(PREDEC) POSTTERM
MSH2 MACMSH = NEWDEC ';' POSTTERM :(RETURN)
* CASE STATEMENT TRANSFORM, PUTTING IN LABELS AND LO-HI BOUNDS
* EXP.COUNT IS THE CURRENT LABEL
* CASE.DEPTH IS THE NUMBER OF CASES PENDING
CASEXP IDENT(SEGMENT) :S(FRETURN)
CASPAT SEGMENT STOP.SET :F(CASNS)
PRESTOP = PRESTOP SPEC.TERM
LEQ(STOPPER,';') :S(CS.SEMI)F($('CS.' STOPPER))
CASTILL BUILD.STR = BUILD.STR PRESTOP STOPPER
SEGMENT = POSTSTOP :(CASPAT)
CASNS CASEXP = BUILD.STR SEGMENT :(RETURN)
CS.BEGIN
CS.( PAREN.COUNT = PAREN.COUNT + 1 :(CASTILL)
CS.END
CS.) PAREN.COUNT = PAREN.COUNT - 1 :(CASTILL)
CS.SEMI GT(PAREN.COUNT,0) :S(CASTILL)
EXP.COUNT = EXP.COUNT + 1
LABEL = IDENT(LABEL) 'TRUE' :S(CASTILL)
LABEL = ''
TTYOUT = '%CVT ATTEMPT TO PUT MORE THAN ONE LABEL PER LINE'
QUEUE('OUTPUTQ','%(***WARNING***MULTIPLE LABELS)%' CRLF) :(CASTILL)
* SIGNAL THE END OF ONE CASE EXPR
* UNBALANCED CASE MEANS A TES OCCURED UNEXPECTEDLY
* TES POPS THE STACKS RESTORING OLD CASE ENVIRONMENT
CS.TES STOPPER = GT(PAREN.COUNT,0) 'TES %(WARNING: UNBALANCED CASE)%'
HIGH.RANGE<CASE.NO> = EXP.COUNT
CASE.DEPTH = CASE.DEPTH - 1
HOLD = HOLD - 1
(BUILD.STR PRESTOP) (ALL.BLANK ! RPOS(0)) :S(CSTES0)
STOPPER = TABTO(BUILD.STR PRESTOP) STOPPER
STOPPER = CRLF UNFIX(STOPPER) :(CSTES1)
CSTES0 BUILD.STR = DIFFER(BUILD.STR) UNFIX(BUILD.STR) :S(CSTES1)
PRESTOP = UNFIX(PRESTOP)
* UNDENT TES AND SET(SEE BELOW) FROM THE TEXT
CSTES1 SEGMENT = EQ(CASE.DEPTH,0) PRESTOP STOPPER POSTSTOP :S(CASNS)
PAREN.COUNT = POP('PC.STACK')
EXP.COUNT = POP('EC.STACK')
CASE.NO = POP('CN.STACK') :(CASTILL)
CS.CASE EQ(CASE.DEPTH,0) :S(NEWCAS)
PUSH('CN.STACK',CASE.NO)
PUSH('PC.STACK',PAREN.COUNT)
PUSH('EC.STACK',EXP.COUNT)
NEWCAS SEEN.OF = ''
ABS.CASE.NO = ABS.CASE.NO + 1
CASE.NO = ABS.CASE.NO
PAREN.COUNT = 0
EXP.COUNT = 0
CASE.DEPTH = CASE.DEPTH + 1
HOLD = HOLD + 1 :(CASTILL)
CS.OF STOPPER = IDENT(SEEN.OF)
+ 'FROM 0 TO <$$$' CASE.NO '$$$> OF' :F(CASTILL)
SEEN.OF = 'TRUE' :(CASTILL)
CS.SET LABEL = IDENT(LABEL) 'TRUE' :S(CSSET0)
LABEL = ''
TTYOUT = '%CVT ATTEMPT TO PUT OUT MORE THAN ONE LABEL PER LINE'
QUEUE('OUTPUTQ','%(***WARNING***MULTIPLE LABELS)%' CRLF)
CSSET0 BUILD.STR = DIFFER(BUILD.STR) UNFIX(BUILD.STR) :S(CASTILL)
PRESTOP = UNFIX(PRESTOP) :(CASTILL)
* SELECT TRANSFORM ENCLOSES EXPRESSIONS IN []
* SELECT MAY BE NESTED, CASES AND SELECTS MAY BE ENTWINED
SELEXP IDENT(SEGMENT) :S(FRETURN)
SEGMENT SEL.STOP.SET :F(FRETURN)S($('SL.' STOPPER))
SL.TESN SEL.DEPTH = SEL.DEPTH - 1
SELEXP = PRESTOP MIDSTOP 'TES' POSTSTOP :(RETURN)
SL.NSET SELEXP = PRESTOP MIDSTOP 'SET' POSTSTOP :(RETURN)
SL.SELECT
SEL.DEPTH = SEL.DEPTH + 1
SEGMENT BADCODE.NSET :F(FRETURN)
SELEXP = PRESTOP 'SET' POSTSTOP :(RETURN)
SL.: DIFFER(INHIBIT.SELLBL) :S(FRETURN)
SEGMENT SEL.COLON :F(FRETURN)
DIFFER(PRESTOP) :S(SL.LBL)
EXPTERM NAME RPOS(0) :S(FRETURN)
SL.LBL DIFFER(EXPTERM) :S(NOHACK)
* HACK TO PUT [] AROUND QUOTED STRINGS BY LOOKING AT PREVIOUS OUTSTR
OUTSTR HACK.EXPSET :F(NOHACK)
MIDSTOP = OUTSTR MIDSTOP
OUTSTR = ''
NOHACK SELEXP = AT.END(MIDSTOP,'[' EXPTERM ']:') POSTSTOP :(RETURN)
* WATCH OUT FOR PROGRAM LABELS: <POS(0)> <NAME> :
* NOTE: SINCE THE CASE TRANSFORM LOOKS FOR TES AND SET IT MUST
* BE DONE BEFORE THE SELECT TRANSFORM CHANGES SETN AND TESN INTO
* SET AND TES.
* NOTE: SINCE THE SELECT TRANSFORM LOOKS FOR COLONS IT MUST
* BE DONE AFTER THE NORMAL DECLARATION TRANSFORMS HAVE CHANGED
* COMPLEX NAMES INTO A LIST OF NAMES.
* LOCAL X:Y:Z; -> LOCAL X,Y,Z; (WITH NEWLINES ALSO)
* INHIBIT.SELLBL INHIBITS SELECT FROM SEEING NEW CASE LABELS
* IN THE EVENT THAT A CASE IS INSIDE OF A SELECT, SEE ALSO
* SEL.STOP.SET PREVENTS A SELECT STATEMENT FROM BEING
* MISSED IF IT FOLLOWS A NEW CASE LABEL. SELECT INSIDE CASE.
* NOTE: OTHER FACTORS REQUIRE THAT CHARACTER TRANSFORMS
* AND KEYWORD TRANSFORMS PRECEED DECLARATION TRANSFORMS.
* *** OVER ALL ORDERING REQUIRED ***
* CHARACTER -> KEYWORD -> DECLARATION -> CASE -> SELECT
* I/O SECTION, STACKS AND QUEUES
OUTSEC OUTSTR = OUTSTR STRING BRKCH
ENV = $STATE
OUTSTR = IDENT(LINE) OUTSTR EOL :F(CTLOOP)
INHIBIT.SELLBL = ''
GT(HOLD,0) QUEUE('OUTPUTQ',OUTSTR) :S(RDLOOP)
OUTPQ OFFQ = UNQUEUE('OUTPUTQ') :F(OUTDONE)
&ANCHOR = 0
OFFQ TOP.BOUND = HIGH.RANGE<CASE.NUM> :S(OUTPQ0)
OFFQ TOP.BOUND = '%(***WARNING***HIGH BOUND?)%' :F(OUTPQ0)
TTYOUT = '%CVT UNABLE TO FIND CASE HIGH BOUND'
OUTPQ0 &ANCHOR = 1
FILEOUT = OFFQ :(OUTPQ)
OUTDONE FILEOUT = OUTSTR :(RDLOOP)
* HOLD > 0 QUEUE THE OUTPUT LINES
* HOLD = 0 UNQUEUE ALL QUEUED LINES AND THEN OUTPUT CURRENT LINE
* QUEUE AND STACK DATA ABSTRACTIONS
QUEUE CURRENT = QNAME '.CURRENT'
IDENT($CURRENT) :S(MAKEQ)
CDR($CURRENT) = CELL(QVAL)
$CURRENT = CDR($CURRENT) :(RETURN)
MAKEQ $QNAME = CELL(QVAL)
$CURRENT = $QNAME :(RETURN)
UNQUEUE $(QNAME '.CURRENT') = IDENT($QNAME) '' :S(FRETURN)
UNQUEUE = CAR($QNAME)
$QNAME = CDR($QNAME) :(RETURN)
PUSH $SNAME = CELL(SVAL,$SNAME) :(RETURN)
POP IDENT($SNAME) :S(FRETURN)
POP = CAR($SNAME)
$SNAME = CDR($SNAME) :(RETURN)
* END OF PROGRAM
XEND EQ(HOLD,0) :S(XXEND)
TTYOUT = '%CVT INTERNAL TROUBLES, OUTPUT REMAINS QUEUED.'
FILEOUT = FF '! CVT ******FORCED UNQUEUING FOLLOWS******' CRLF
HOLD = 0 :(OUTPQ)
XXEND ENDFILE(FILES.OUT<FILE.NUM>)
ENDFILE(FILES.IN<FILE.NUM>)
TTYOUT = EQ(FILE.NUM,NUM.FILES) CRLF CRLF :F(MAIN)S(FILGET)
XXXEND &DUMP = 0
END