/DATA ENTRY FORMS COMPILER EDITED 11/2/73 / /COPYRIGHT 1973 /DIGITAL EQUIPMENT CORPORATION /MAYNARD, MASS. 01754 / /SGW WITH A FEW HACKS FROM RL /MODS BY JGD / /THIS SOFTWARE IS FURNISHED TO PURCHASER UNDER A LICENSE FOR USE /ON A SINGLE COMPUTER SYSTEM AND CAN BE COPIED (WITH INCLUSION /OF DEC'S COPYRIGHT NOTICE) ONLY FOR USE IN SUCH SYSTEM, EXECPT /AS MAY OTHERWISE BE PROVIDED IN WRITING BY DEC. / /THE INFORMATION IN THIS DOCUMENT IS SUBJECT TO CHANGE WITHOUT /NOTICE AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DIGITAL /EQUIPMENT CORPORATION. / /DEC ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY /OF ITS SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DEC. VERSION= 2 /TO BE CHECKED BY "OVERLA" /DEFINITIONS XR12=12 XR13=13 XR14=14 XR15=15 XR16=16 XR17=17 AC0001= CLA IAC AC0002= CLA CLL CML RTL AC4000= CLA CLL CML RAR AC7775= CLA CLL CMA RTL AC7776= CLA CLL CMA RAL AC7777= CLA CMA BITZ= 0001 BITS= 0002 BITRAR= 0004 BITA= 0020 BITC= 0040 BITD= 0100 BITF= 0200 BITJ= 0400 BITR= 1000 BITT= 2000 BITNUM= 0010 FORMBT= 0001 DATABT= 0002 /MONITOR DEFINITIONS (PERMANENT, WE HOPE) P7400= 2 P77= 20 CTCFG= 21 KMOVE= 23 KGETC= 24 KPUTC= 25 KRDOIO= 26 KCDOIO= 27 TTYIN= 30 TTYOUT= 31 CDIN= 32 PPOUT= 33 PRIN= 34 LPOCHR= 35 P7= 40 KPTRST= 43 LENGTH= 44 M1= 45 W0= 46 W1= 47 W2= 50 W3= 51 W4= 52 W5= 53 GET= 57 PUT= 60 TEMP= 61 COUNT= 62 NMBR= 63 P17= 64 P70= 65 M4= 66 P7600= 70 PCDF= 71 KINIT= 72 KCTRLO= 73 KOTOPD= 74 KCLOSE= 75 KSPLIT= 76 SYSHND= 77 SBT= 6370 SWITCH= 7776 BINWRK= 100 /BLK # OF BIN WORK AREA / *100 / /NOW USEFUL THINGS FOR PAGE 0 / /A LIST OF TEMPORARIES AND NOT-SO-TEMPORARIES / OPTWRD, 0 /THIS GETS ITS BITS DIDDLED ACCORDING TO WHICH OPTIONS /ARE REQUESTED FOR A PARTICULAR FIELD TYPSIZ, 0 /THIS GETS THE TYPE AND SIZE OF THE FIELD TERMIN, 0 /THE TERMINATOR OF #S OR NAMES GETS STUFFED IN HERE STATUS, 0 /KEEPS TRACK OF WHAT WE SHOULD EXPECT LINENO, 0 /THE BINARY LINE # OF LINE WE'RE ON LINSIZ, 0 /GETS SET TO WIDTH OF PRINTER COLSET, -110 /...WHICH IS THIS LINCNT, -1 /GETS SETS TO # OF LINES PER PAGE PAGSET, -70 /...WHICH IS THIS NAM1, 0 NAM2, 0 NAM3, 0 TABS, -10 /TAB POSITION COUNTER CHAR, 0 /GENERALLY, THE CURRENT CHARACTER OF INTEREST NUMBR, 0 NUMFLG, 0 /GETS SET TO -1 IF WHAT WE THOUGHT MIGHT BE A NAME /TURNED OUT TO BE A # TARG, 0 /TEMP FOR ARG TO "T" OPTION LISTSW, 1 /SET TO 0 IF NOLIST (/N) ERRCNT, 0 /# OF ERRORS DETECTED FLDSIZ, 0 /(-) THE SIZE OF CURRENT FIELD -1 *200 CLA START, JMP I (STRTUP /EXECUTE ONCE-ONLY INITIALIZATION CODE REINIT, AC0001 /INIT IFN #1 FOR INPUT JMS I (SYSINI /FROM "FORM" FILE 2010 /10 BLOCKS, FIELD 1 4000 /STARTING AT LOCATION 4000 JMP I (GOTEOF /NO MORE INPUT - CLOSE US OUT GETLIN, AC0001 JMS I KRDOIO /GET A LINE FROM INPUT FILE (#1) LINBUF-1 /PUT IT HERE JMP REINIT /IF END FILE SEEN, TRY RE-INITING AC0002 /SET REL. CHARACTER = 2 DCA I (RELC /TO SKIP LINE # NOW JMS I [NAME /WE WANT A NAME HERE SMA CLA /IF WE RETURN WITH A NON-NEGATIVE AC, JMP GOTNUM /WE GOT A # INSTEAD OF A NAME JMS I [CHKNAM /SEE IF WHAT WE GOT WAS A NAME, AND IF -4760 /FO IT WAS "FORM" -6356 /RM -0101 /** FILL OUT WITH SPACES! ** GOTFRM /IF IT WAS, GO TO THIS PLACE JMS I [CHKNAM /STRUCK OUT AGAIN, TRY FOR "END" -4657 -4501 -0101 GOTEND JMS I [ERRMSG /NO - GUY LOSES ON THIS LINE BADWRD-1 /--UNRECOGNIZABLE LINE-- GOTNUM, AC0001 AND STATUS /IS IT LEGAL TO GET A # HERE? SNA CLA JMP I (BADSEQ / -- STATEMENTS MISSING OR OUT OF ORDER -- TAD TERMIN /SEE IF # ENDED WITH A COMMA JMS I [COMACK /IF WE RETURN, IT DID TAD NUMBR /YES, EVERYTHING IS GROOVY. GET THE # SNA JMP ROW0 /CHECK FOR NULL R,C TAD (-23 /AND SEE IF 1<=X<=18 CLL TAD (23 SNL JMP I (BADNUM / -- NUMBER TOO LARGE OR 0 -- CLL RTR RTR RTR /MOVE IT TO A GOOD PLACE DCA LINENO /FOR LATER COMBINATION WITH COLUMN # JMS I [NUMBER /NOW GO AFTER THE COLUMN # TAD (-110 /-72 IN DISGUISE CLL TAD (110 SNL JMP I (BADNUM / -- NUMBER TOO LARGE OR 0 -- SNA CLL TAD LINENO /COMBINE WITH COLUMN # SZA SNL JMP I (BADNUM GOODNM, DCA LINENO /BITS 0-4=LINE #, BITS 5-11=COLUMN # TAD TERMIN JMS I [COMACK /MAKE SURE IT ENDED WITH A COMMA JMS I [GETCHR /FORM SECTION...GET TEXT JMP NOTEXT /WE MUST HAVE SOME! TAD [-10 /LOOK FOR OPENING ' SZA JMP I (DSECT /SEE IF DSECT TAD LINENO JMS I [OUTFRM DCA TEXCNT /ZERO OUT CHARACTER COUNTER GTTEXT, DCA SAVEL JMS TEXTGT CLL RTL RTL RTL DCA SAVEL JMS TEXTGT TAD SAVEL JMS I [OUTFRM JMP GTTEXT TEXTGT, 0000 JMS I (GETIT /GET A CHAR, REGARDLESS WHAT IT IS JMP NOTEXT /PREMATURE EOL TAD [-10 SNA /IS IT THE CLOSING '? JMP ENDTXT /YEA! TAD [10 ISZ TEXCNT JMP I TEXTGT SAVE, 0 /SAVE IS ALSO BUFFER ADDR TEXCNT, 0 SAVEL, 0000 /TEMPORARY SAVE FOR TEXT GET ENDTXT, TAD SAVEL /SEE IF ANY REMAINING CHARACTERS JMS I [OUTFRM /OUTPUT LAST CHAR, OR 0000 IF NONE JMS I [GETCHR SKP JMP EXTRA / -- EXTRA CHARS AT END OF LINE -- JMS I [PRNTLN JMP I [GETLIN ROW0, JMS I [NUMBER SNA CLA JMP GOODNM /SPECIAL CASE JMP I (BADNUM EXTRA, DCA TERMIN TAD LINENO SNA /DON'T ALLOW A 0,X X>0 JMP I (BADNUM TAD TEXCNT JMP GOODNM / NOTEXT, JMS I [ERRMSG BADTXT-1 /"BAD TEXT" / PAGE DSECT, TAD (-42+10 /CHECK IT FOR A... SNA JMP GOTTYP TAD (-3 /OR D SZA CLA JMP BADTYP / -- NOT A OR D -- AC4000 GOTTYP, DCA OPTWRD /IF DECIMAL, BIT 0 = 1 TAD LINENO JMS I [OUTDAT TAD OPTWRD RAL CLA RAL /SET UP DELTA = 0 FOR ALPHA, = 1 FOR DECIMAL TAD LINENO AND (177 /SAVE JUST THE COLUMN DCA LINENO TAD OPTWRD /LOOK AT TYPE NOW, TO SEE IF SMA CLA /WE WANT ALPHA OPTION LIST TAD (TRYA-TRYC /OR DECIMAL OPTION LIST TAD (TRYC DCA I (BRANCH /STORE THE CORRECT POINTER JMS I [NUMBER /NOW GET THE FIELD SIZE TAD LINENO TAD (-111-1 /CHECK FOR 1<=X+COLUMN+DELTA<=72 CLL TAD (111+1 SNL JMP BADNUM / -- NUMBER TOO LARGE OR 0 -- CIA TAD LINENO /NOW REMOVE THE LINE NUMBER (COLUMN) DCA TYPSIZ TAD TYPSIZ JMS I [OUTDAT TAD NUMBR /FIELD SIZE IS STILL SITTING HERE CMA /PREPARE FOR POSSIBLE "R" OPTION DCA FLDSIZ TAD TERMIN /MAKE SURE THE OL' COMMA WAS THERE SNA JMP I (EOL /LINE ENDED AFETER FIELD...NO OPTIONS, NO INITIAL VALUE CHKOPT, JMS I [COMACK JMS I [GETCHR /LOOK FOR A ', OR SOME OPTION CHARS, OR THE END OF LINE JMP I (EOL /GROOVY - THIS LINE IS COMPLETE JMP I (CSJ /GO TO NEXT PAGE / GETIT, 0 TAD I (RELC /GET OLD CHAR POSITION DCA KRELC TAD (LINBUF JMS I KGETC KRELC, 0 ISZ I (RELC SZA /EOL? ISZ GETIT /NOT YET - BUMP RETURN JMP I GETIT / BADNUM, JMS I [ERRMSG ILLNUM-1 /NUMBER TOO LARGE OR 0 BADTYP, JMS I [ERRMSG ILLTYP-1 /NOT A OR D / PAGE CSJ, JMS I (SORTJ /NO, WE'VE STILL GOT TO DO SOME WORK -10;TRYF /LOOK FOR A ' TO START AN INITIAL VALUE GETVAL, JMS I (GETIT /GOT A ', SCAN OFF INITIAL VALUE JMP NOINIT / -- BAD INITIAL VALUE -- TAD [-10 SNA /IS THIS THE CLOSING '? JMP ENDVAL /YES TAD [10 /RESTORE CHARACTER'S ORIGINAL PRISTINE GOODNESS ISZ FLDSIZ /BUT BEFORE HASTY ACTION... SKP /MAKE SURE WE DON'T EXCEED FIELD SIZE JMP OVRFLO / -- INITIAL VALUE TOO LONG -- JMS I [PUTCHR /NO, ALL IS RIGHT WITH THE WORLD JMP GETVAL /CONTINUE THE SCAN ENDVAL, ISZ FLDSIZ /IF WE FILLED FIELD, SHOULD SKIP JMP NOINIT / -- BAD INITIAL VALUE -- JMS I [GETCHR /SEE IF ANYTHING FOLLOWS JMP I [OUTCOD /...NOTHING SHOULD JMP I (EXTRAC / -- EXTRA CHARACTERS AT END OF LINE -- EOL, ISZ FLDSIZ /FILL OUT FIELD WITH BLANKS IF INITIAL VALUE WAS SHORT, SKP /OR IF THERE WASN'T ONE JMP I [OUTCOD /LINE FINISHED! OUTPUT THE CODE FOR IT AC0001 JMS I [PUTCHR /OUTPUT A SPACE JMP EOL /& LOOP UNTIL FIELD SIZE SATISFIED TRYF, -47;TRYD /IN CASE YOU'VE FORGOTTEN, WE'RE STILL IN SORTJ JMS I (CHKDUP /LOOK FOR PREVIOUS OCCURANCE OF F OPTION KBITF, BITF SETOPT, TAD OPTWRD /SET THE F BIT IN THE OPTION WORD DCA OPTWRD JMS I [GETCHR /GET WHAT SHOULD BE A COMMA JMP EOL /NO MORE OPTIONS JMP I (CHKOPT /REPEAT THE PROCESS FOR NEXT OPTION TRYD, -45;TRYZ TAD OPTWRD /BIT D AND BIT Z ARE MUTUALLY EXCLUSIVE AND KBITZ /SO CHECK FOR PRESENCE OF BIT Z SZA CLA JMP BADCOM / -- ILLEGAL OPTION COMBINATION -- JMS I (CHKDUP KBITD, BITD TRYZ, -73 BRANCH, TRYC / ** -- THIS CHANGES TO TRYA IF WE'RE WORKING WITH AN ALPHA FIELD -- ** TAD OPTWRD /MAKE SURE BIT D ISN'T ON HERE AND KBITD SZA CLA JMP BADCOM /IT IS, YOU IDIOT! JMS I (CHKDUP /CHECK FOR PRIOR OCCURANCE OF D NOW KBITZ, BITZ TRYC, -44;TRYT JMS I (CHKDUP KBITC, BITC TRYT, -65;TRYR JMS I (CHKLPR /LOOK FOR A LEFT PAREN NEXT JMS I [NUMBER /SHOULD GET A # 0-9 NEXT TAD (-12 CLL TAD (12 SNL JMP I (BADNUM CLL RTR RTR RAR /PUT IN BITS 0-3 DCA TARG /SAVE IT AS THE ARG FOR T OPTION TAD TERMIN /GET THE THING WOT ENDED THE NUMBER TAD (-12 /CHECK IT FOR BEING A ")" SZA CLA JMP I (NOPARN / -- PARENTHESIS EXPECTED, NONE SEEN -- JMS I (CHKDUP KBITT, BITT /LOOK FOR DUPLICATE BIT T JMP SETOPT TRYR, -63;TRYJ JMS I (CHKLPR /LOOK FOR A LEFT PAREN TAD (-36 DCA COUNT TAD (RARG-1 DCA XR14 DCA I XR14 /ZERO OUT STORAGE AREA FOR RANGE ARGS ISZ COUNT /EACH CAN BE UP TO 15 DIGITS LONG! JMP .-2 /BARF! TAD (RARG-1 /NOW PREPARE TO GET THE ARGS DCA XR14 JMS I (GETARG JMS I [COMACK /SEE THAT FIRST ARG ENDED WITH A COMMA JMS I (GETARG /GET THE 2ND ARG NOW TAD (-12 /TERMINATOR OF ARG RETURNS IN AC... SZA CLA /IT SHOULD BE A RIGHT PAREN... JMP I (NOPARN /IT AIN'T JMS I (CHKDUP /...WE STILL HAVE TO SEE KBITR, BITR /IF DUPLICATE R OPTION JMP SETOPT TRYJ, -53;BADOPT /THIS IS THE END OF THE LINE FOR LEGAL D-FIELD OPTIONS JMS I (CHKDUP KBITJ, BITJ NOINIT, JMS I [ERRMSG NOAPOS-1 /BAD INITIAL VALUE OVRFLO, JMS I [ERRMSG INIOVR-1 /INITIAL VALUE TOO LARGE BADOPT, 0 CLBDOP, JMS I [ERRMSG ILLOPT-1 / -- UNKNOWN OR ILLEGAL OPTION -- BADCOM, JMS I [ERRMSG ILLCOM-1 /"ILLEGAL OPTION COMBINATION" / PAGE /NOW WE HAVE THE LINKED LIST FOR GOOD ALPHA OPTIONS... IN CASE YOU'VE /FORGOTTEN, BACK AT "TRYZ" WE MIGHT HAVE COME HERE. / TRYA, -42;TRYNUM TAD KBITNM AND OPTWRD /CAN'T HAVE BOTH OPTION A AND OPTION # SZA CLA /IS GUY TRYING TO DO THAT? JMP I (BADCOM /SURE IS...DON'T LET HIM JMS I (CHKDUP KBITA, BITA TRYNUM, -4;BADOPT /END OF LINE FOR ALPHA OPTIONS TAD KBITA AND OPTWRD /DO THE SAME CHECK IF WE SEE A # SZA CLA JMP I (BADCOM JMS I (CHKDUP KBITNM, BITNUM / GOTEND, JMS I [GETCHR SKP JMP I (EXTRAC / -- EXTRA CHARS AT END OF LINE -- JMS I [PRNTLN /PRINT "END" LINE GOTEOF, TAD LISTSW SNA CLA JMP LSTOFF //N IN EFFECT JMS I [LPCRLF TAD (214 JMS I [PRNTC /EJECT AT END OF INPUT LSTOFF, JMS CRLF /SET TO PRINT ERROR COUNT ON TTY JMS CRLF JMS I [OUTDAT /PUT DOUBLE NULL AT END OF LIST JMS I [OUTDAT JMS I [OUTFRM /AND A NULL AT THE END OF THE FORM SECTION AC7777 TAD ERRCNT SNA /CHECK FOR ONLY 1 ERROR DCA I (NOESS /KNOCK OFF "S" ON MESSAGE IAC SNA CLA /CHECK FOR NO ERRORS JMP PRNTE /NO ERRORS! TAD ERRCNT JMS I KOTOPD DCA I (ECNT PRNTE, AC0001 JMS I KCDOIO EMES-1 NOP JMS CRLF TAD I [ERRMSG SZA CLA /WERE THERE ANY ERRORS? JMP I P7600 /YES THERE WERE AC7777 TAD STATUS SZA CLA /DID EVERYTHING GET DONE? JMP I P7600 /NOPE, SOMETHING WAS OMITTED TAD (776+1 TAD I (RFREE SZA CLL CML CMA RAR SZL /CHECK FOR ODD-EVEN IAC /BUMP BACK ONE IF EVEN CDF 10 DCA I (RECBUF /PUT IN WORD COUNT CDF 0 TAD (BINWRK JMS I KSPLIT JMS I SYSHND 4400 /WRITE OUT TEXT+FORM DISCRIPTORS CODBUF /THE TWO MUST BE SEQUENTIAL! 0 TAD (BINWRK+2 JMS I KSPLIT JMS I SYSHND 4210 /NOW FOR THE RECORD IMAGE RECBUF 0 JMP I P7600 / CRLF, 0 /PRINT CRLF ON TTY TAD (215 JMS I TTYOUT TAD (212 JMS I TTYOUT JMP I CRLF / PAGE / S U B R O U T I N E S A N D O T H E R U N M E N T I O N A B L E S / /ROUTINE TO GET A CHARACTER FROM INPUT FILE /CALL: / JMS GETCHR / / / /THE ROUTINE IGNORES BLANKS, TABS, AND COMMENTS / GETCHR, 0 ONECHR, TAD (LINBUF JMS I KGETC /GET CHAR FROM LINE BUFFER RELC, 0 /THE RELATIVE CHARACTER # SNA /0 IF EOL JMP I GETCHR /TAKE EOL RETURN ISZ RELC /BUMP TO NEXT CHAR TAD M1 SNA /SPACE? JMP ONECHR /YUP - PRETEND IT NEVER HAPPENED TAD (1-75 SNA /HOW ABOUT A TAB? JMP ONECHR /IGNORE IT AND IT WILL GO AWAY TAD (75-34 SNA /SEMICOLON, INDICATING A COMMENT? JMP I GETCHR /FORGET THE WHOLE LINE! TAD (34 /RESTORE CHAR TO ITS VIRGIN PURITY ISZ GETCHR /POINT TO GOOD EXIT JMP I GETCHR /AND TAKE IT /SORTJ WITH A DIFFERENCE /OTHERWISE KNOWN AS AN RL-ISM /IT USES LINKED LISTS /ENTER WITH CHAR TO MATCH IN AC. /FOLLOW THE CALL TO SORTJ BY CODE OF THE FORM: / -CHAR1;ADDR1 TO GO TO IF CHAR1 IS NOT A MATCH / / ADDR1, -CHAR2;ADDR2 / / CHKLPR, 0 JMS GETCHR /GET CHAR TO CHECK JMP NOPARN /WE SHOULD HAVE GOTTEN SOMETHING! TAD (-11 / -( IN DISGUISE SNA CLA JMP I CHKLPR NOPARN, JMS I [ERRMSG PARENS-1 /ROUTINE TO GET ARGS FOR RANGE CHECK. /ARG SIZE MUST EXACTLY EQUAL FIELD SIZE /CALL WITH GET POINTER SET TO GET FIRST DIGIT / GETARG, 0 TAD TYPSIZ DCA COUNT /COUNTER FOR FIELD SIZE GTRARG, JMS I [GETCHR JMP BADARG /WE NEEDED ONE! JMS I [NUMCHK /IS IT 0-9? JMP BADARG /NOPE...PROBABLY ARG TOO SHORT DCA I XR14 /SAVE IN MAGIC BUFFER ISZ COUNT /FIELD FULL? JMP GTRARG /NOT YET JMS I [GETCHR /GET NEXT IN LINE JMP BADARG /...AND THERE BETTER BE ONE! JMP I GETARG /IN PREPARATION FOR CHECKING FOR LEGAL TERMINATOR BADARG, JMS I [ERRMSG BADSIZ-1 / -- BAD ARGUMENT FOR "R" OPTION -- OUTCOD, TAD OPTWRD /END OF LINE SEEN, OUTPUT SOMETHING APPROPRIATE JMS I [OUTDAT /THEN OPTIONS (IF ANY) TAD OPTWRD SMA CLA /DECIMAL FIELD? JMP ROPT /NO OUTPUT OF 0000 IN ALPHA FIELD TAD TARG /GET THE T ARG JMS I [OUTDAT /AND SEND IT OUT 0000 IF NO T OPT (FOR SIGN) ROPT, TAD OPTWRD AND (BITR /NOW INVESTIGATE THE R BIT SNA CLA /IS IT LURKING IN THE WOODS? JMP LISTIT /NO, THANK GOODNESS TAD TYPSIZ /BECAUSE IT IS A PAIN DCA COUNT /BECAUSE THERE ARE TWO ARGS TO GET TAD (RARG-1 DCA XR14 ROUTLP, TAD I XR14 CLL RTL /WE MUST DO THIS JAZZ RTL RTL TAD I XR14 TAD (2121 /MAKE COS 300 -237 CODES JMS I [OUTDAT /OUTPUT TWO DIGITS ISZ COUNT /DONE ALL? JMP ROUTLP /NO SUCH LUCK LISTIT, JMS I (PRNTLN /LIST THE LINE WE JUST COMPILED DCA OPTWRD /0 IN PREPARATION FOR NEXT LINE DCA TARG JMP I [GETLIN / PAGE /COME HERE IF "FORM" STATEMENT SEEN GOTFRM, TAD TERMIN SZA CLA JMP EXTRAC /EXTRA CHARS AT END OF LINE TAD STATUS SZA CLA /"FORM" MUST BE FIRST THING! JMP BADSEQ / -- STATEMENTS MISSING OR OUT OF ORDER -- TAD (FORMBT SETSST, TAD STATUS DCA STATUS /SET THE BIT JMS I [PRNTLN JMP I [GETLIN EXTRAC, JMS I [ERRMSG GARBGE-1 /"EXTRA CHARS AT END OF LINE" BADSEQ, JMS I [ERRMSG ILLSEQ-1 /"STATEMENTS MISSING OR OUT OF ORDER" / /ERROR MESSAGE ROUTINE /IT PRINTS: / THE LINE THAT IS IN ERROR / A LINE WITH A CARET OR UPARROW POINTER TO WHERE SCANNER DIED / A LINE OF EXPLANATORY TEXT / A BLANK LINE / ERRMSG, 0 ISZ ERRCNT AC0001 /FORCE LISTING EVEN IF /N JMS PRNTLN /FIRST, PRINT BAD SOURCE LINE JMS LPCRLF TAD M4 DCA COUNT DCA OPTWRD HYPOUT, TAD (255 /NOW PRINT 4 HYPHENS (-) JMS I [PRNTC ISZ COUNT JMP HYPOUT AC7776 /BACK UP A COUPLE CHARS TAD I (RELC /GET HOW FAR WE GOT ON LINE CIA DCA COUNT /TO USE AS COUNTER TO SPACE OVER TO ERROR SPCLUP, TAD (240 JMS I [PRNTC ISZ COUNT JMP SPCLUP TAD (336 /GET CODE FOR ^ JMS LPCRLF /PRINT IT PLUS CRLF TAD I ERRMSG /GET POINTER TO EXPLANATORY ERROR TEXT DCA EMPTR JMS PAGCHK /MAKE SURE WE HAVE ROOM TAD (5 JMS I KCDOIO EMPTR, 0 NOP JMP I [GETLIN /AND GO GET NEXT SOURCE LINE /BEHOLD, A ROUTINE TO PRINT A SOURCE LINE COMPLETE WITH BINARY LINE # /AND TABS, PAGE HEADINGS AND WRAP-AROUND ON LINE OVERFLOWS. /DO YOU REALLY THINK THIS WILL DO ALL THAT??? PRNTLN, 0 TAD LISTSW SNA CLA /DID GUY SPECIFY /N? JMP I PRNTLN /YES JMS LPCRLF /PRINT CRLF -- BEFORE -- THE LINE ! ! ! TAD (TENTBL DCA GET /GET POINTER TO TEN TABLE TAD M4 DCA COUNT /4 DIGITS, BELIEVE IT OR NOT DCLOOP, TAD (260 DCA NUMBR /START US AT 0 DCLUP, TAD I (LINBUF+1 /FIRST, PRINT LINE # CLL /IN ALL ITS GLORY TAD I GET /...SUBTRACT POWER OF TEN SNL JMP NXTPWR /UNDERFLOW, OVERFLOW...WE WENT TOO FAR DCA I (LINBUF+1 /SAVE INTERMEDIATE RESULT ISZ NUMBR /BUMP DIGIT JMP DCLUP /AND HAVE ANOTHER ROUND NXTPWR, CLA TAD NUMBR /GET WHAT WE GOT JMS I [PRNTC /AND PRINT IT ISZ GET /GOT TO NEXT LOWER POWER OF 10 ISZ COUNT /FOUR DIGTS WORTH? JMP DCLOOP /NOT YET TAD (240 JMS I [PRNTC /SPACE AFTER # AC0002 /SKIP OVER LINE # DCA PRELC /AND SET UP TO PRINT ACTUAL LINE TAD [-10 DCA TABS OUTCHR, TAD (LINBUF JMS I KGETC PRELC, 0 SNA /EOL? JMP ENDLIN /IT CERTAINLY IS TAD (237 /CONVERT COS 300 ABORTION TO REAL ASCII JMS I [PRNTC ISZ PRELC /BUMP TO NEXT CHAR JMP OUTCHR ENDLIN, JMP I PRNTLN /HERE IS A THINGIE TO PRINT CRLF AND RESET PAGE IF WE GO TOO FAR, ETC. /IT ALSO HAS THIS THING WHERE IF AC .NE. 0 ON ENTRY, IT PRINTS THE AC /PLUS A CRLF. LPCRLF, 0 SZA JMS I [PRNTC /OUTPUT WHATEVER IT WAS JMS PAGCHK /MAKE SURE WE HAVE ROOM ON PAGE PAGEOK, TAD (215 JMS I LPOCHR TAD (212 JMS I LPOCHR TAD COLSET DCA LINSIZ /RESET COLUMN COUNTER TAD [-10 DCA TABS /RESET TAB COUNTER JMP I LPCRLF PAGCHK, 0 ISZ LINCNT /STILL GOT ROOM ON PAGE? JMP I PAGCHK /YUP TAD PAGSET /'FRAID NOT, GOT TO RESET COUNTER DCA LINCNT TAD K214 JMS I LPOCHR /THEN PRINT FORMFEED TAD (5 JMS I KCDOIO /PRINT HEADER TEXT HEADER-1 K214, 214 ISZ I (PAGENO /BUMP PAGE # ...IT'LL NEVER EXCEED 9! (FAITH, FAITH) JMP I PAGCHK / PAGE /HERE IS THE ROUTINE TO PRINT A CHARACTER /IT HANDLES TABS AND LINES THAT ARE TOO LONG / PRNTC, 0 DCA CHAR ISZ LINSIZ /SEE IF ROOM ON LINE SKP EOFLIN, JMS I (LPCRLF /IF NOT, GO TO NEXT LINE TAD CHAR TAD (-334 /CHECK FOR TAB (BACKSLASH TRAVELING INCOGNITO) SNA JMP PRTTAB /SURE IS TAD (334 JMS I LPOCHR ISZ TABS /BUMP TAB COUNTEER JMP I PRNTC /NO PROBLEM TABSET, TAD [-10 /GOT TO RESET TAB STOP DCA TABS JMP I PRNTC PRTTAB, TAD (240 JMS I LPOCHR ISZ LINSIZ SKP JMP EOFLIN ISZ TABS JMP PRTTAB JMP TABSET / OUTDAT, 0 /OUTPUT ONE WORD OF CODE ISZ DFREE /IS THERE ROOM? SKP JMP BUFOVR /NO! DOUT, DCA I XR15 JMP I OUTDAT BUFOVR, CLA CLL TAD P7600 DCA DOUT /SUPPRESS FUTURE OUTPUT OVEMES, JMS I [ERRMSG FULLUP-1 / -- DATA OVERFLOW! -- DFREE, -400 OUTFRM, 0000 ISZ FFREE SKP JMP BUFOV FOUT, DCA I XR16 JMP I OUTFRM BUFOV, CLA CLL TAD P7600 DCA FOUT JMS I [ERRMSG TXTOVR-1 / -- TEXT OVERFLOW! -- FFREE, -400+STRTUP-CODBUF PUTCHR, 0 /OUTPUT ONE CHAR OF RECORD IMAGE DCA TEMP ISZ RFREE /IS THERE ROOM? SKP JMP RECOVR /NO! AC7777 TAD TEMP SNA CLA /SPACE? JMP ROUT /ALWAYS GOOD TAD OPTWRD SPA CLA /A OR D FIELD? JMP DCHK /IT'S D TAD OPTWRD AND (BITA SZA CLA /DO WE HAVE "A" OPTION? JMP ACHK /YUP TAD OPTWRD AND (BITNUM SNA CLA JMP ROUT /NO OPTIONS - TAKE WHAT WE GET TAD TEMP TAD (-33 /# OPTION MEANS IN RANGE "+" TO "9" CLL TAD (17 SNL CLA JMP BADCHR /OUT OF RANGE! ROUT, TAD TEMP CDF 10 JMS I KPUTC RECBUF RECCHR, 0 CDF 0 ISZ RECCHR RHACK, JMP I PUTCHR RECOVR, TAD RHACK DCA ROUT /SUPPRESS FUTURE OUTPUT JMS I [ERRMSG RECFUL-1 / -- OUTPUT RECORD EXCEEDS 510 CHARS -- RFREE, -776-1 /THIS IS A CHAR COUNT, REMEMBER (ISZ DONE FIRST) ACHK, TAD TEMP TAD (-74 /CHECK FOR A-Z CLL TAD (32 SZL CLA JMP ROUT /EVERYTHING OK BADCHR, JMS I [ERRMSG ILLCHR-1 / -- ILLEGAL CHAR IN INITIAL VALUE -- / DCHK, TAD TEMP TAD (-33 /DIGITS 0-9 ONLY CLL TAD (12 SNL CLA JMP BADCHR JMP ROUT / / PAGE /ROUTINE TO VERIFY A NAME (6 CHARS) /CALL: / JMS CHKNAM / -WA /THE SIX / -NT /CHARACTERS / -ED /WANTED / ADDRESS /THE PLACE TO GO IF A MATCH / CHKNAM, 0 AC7777 TAD CHKNAM DCA XR14 TAD I XR14 TAD NAM1 SNA CLA TAD NAM2 TAD I XR14 SNA CLA TAD NAM3 TAD I XR14 SZA CLA JMP NOCHK TAD I XR14 /WE GOT A MATCH - GET THE PLACE TO GO DCA CHKNAM JMP I CHKNAM /AND GO THERE NOCHK, ISZ XR14 /BUMP ADDRESS PAST GOOD ADDRESS JMP I XR14 / NUMCHK, 0 /VERIFIES THAT A CHAR IS 0-9 TAD (-33 CLL TAD (12 SZL ISZ NUMCHK /BUMP TO GOOD RETURN IF A # JMP I NUMCHK /ROUTINE TO GET A NAME FROM INPUT LINE /DELIMITERS ARE COMMA, SLASH, AND EOL /NAME GETS PUT IN NAM1-NAM3 /CHARACTERS AFTER 6 ARE IGNORED /IF FIRST CHAR IS A NUMBER, WE GO TO "NUMBER" / NAME, 0 TAD (0101 /FIRST, INITIALIZE NAME TO SPACES DCA NAM1 TAD NAM1 DCA NAM2 TAD NAM2 DCA NAM3 TAD (-7 DCA COUNT TAD NAME /PREPARE FOR CASE THAT IT'S A NUMBER DCA NUMBER /AND WE JUMP INTO MIDDLE OF ROUTINE JMS I [GETCHR JMP BLNKLN /MUST BE A BLANK LINE JMS NUMCHK /IS FIRST CHAR A #? SKP JMP ITSNUM /SHO NUFF TAD (21 /RESTORE CHAR JMP ITSOK /CHECK FOR TERMINATOR OUTONE, ISZ COUNT /GOT 6 CHARS? JMP NOTYET /NOPE AC7777 DCA COUNT /FIX UP TO IGNORE >6 CHARS JMP GETNMC NOTYET, TAD COUNT CLL CML RAR /DIVIDE NEG # BY 2 TAD (NAM1+3 /MAKE UP AN RL-ISM POINTER DCA TEMP TAD P77 /MAKE UP THIS MASK SNL /ACCORDING TO WHICH HALF TAD (7601 /TO BE 7700 OR 0077 AND I TEMP DCA I TEMP TAD TERMIN /GET CHAR NOW SNL JMP RITE /IT GOES IN THE RIGHT HALF CLL RTL RTL RTL RITE, TAD I TEMP /ADD TO PROPER HALF DCA I TEMP GETNMC, JMS I [GETCHR NOP /EOL = 0 ITSOK, TAD (-34 /IS IT ;? SZA TAD (34 /NOPE DCA TERMIN TAD TERMIN SZA /WAS IT ; OR EOL? TAD (-15 SNA /HOW ABOUT COMMA? JMP .+4 /EUREKA, ARCHIMEDES! TAD (-3 /HOW ABOUT SLASH? SZA CLA JMP OUTONE /NOPE AC7777 JMP I NAME ITSNUM, DCA NUMBR /SAVE FIRST DIGIT DCA NUMFLG JMP GETDIG /JMP INTO MIDDLE OF "NUMBER" BLNKLN, JMS I [PRNTLN /PRINT THE BLANK LINE JMP I [GETLIN /AND TRY AGAIN /ROUTINE TO GET A # AND SAVE IT IN "NUMBR" /TERMINATOR GOES IN "TERMIN" / NUMBER, 0 DCA NUMBR /CLEAR OUT AC7777 DCA NUMFLG /SET "NO NUMBER YET" GETDIG, JMS I [GETCHR NOP JMS NUMCHK JMP ENDNUM /NOT A DIGIT MEANS END OF # DCA TEMP DCA NUMFLG /SET "WE GOT SOMETHING" TAD NUMBR CLL RTL /MULTIPLY BY 10 TAD NUMBR RAL TAD TEMP /ADD IN NEW DCA NUMBR JMP GETDIG /KEEP GOING ENDNUM, TAD (21 /RESTORE TERMINATING CHAR DCA TERMIN TAD NUMBR ISZ NUMFLG /DID WE GET ANYTHING? JMP I NUMBER JMS I [ERRMSG ILLNUM-1 /# TOO LARGE OR 0" / PAGE /INITIALIZE A SOURCE FILE FOR RDOIO INPUT SYSINI, 0 JMS I KPTRST /ENTER WITH IFN IN AC TAD I SYSINI DCA I W0 ISZ SYSINI TAD I SYSINI /GET BUFFER ADDR ISZ SYSINI DCA I W1 TAD (SBT-1 DCA GET X, ISZ GET TAD I GET SNA JMP I SYSINI CMA SNA JMP X CLL CMA RAR RTR RTR DCA TEMP TAD TEMP AND P7400 DCA I W5 TAD TEMP RAL AND (377 DCA I W4 AC7777 DCA I GET DCA I W3 ISZ SYSINI JMP I SYSINI / PAGE /HERE ARE ERROR MESSAGES AND A COUPLE OF WAYWARD TABLES / TENTBL, -1750 /USED FOR DECIMAL CONVERSION -144 -12 -1 / RARG, ZBLOCK 40 /USED TO STORE ARGS FOR "R" OPTION / GARBGE, -15 /"EXTRA CHARS AT END OF LINE" 4671 6563 4201 4451 4263 6401 4265 0146 5745 0160 4701 5552 5746 / NOAPOS, -11 /"BAD INITIAL VALUE" 4342 4501 5257 5265 5242 5501 6742 5566 4600 / INIOVR, -14 /"INITIAL VALUE TOO LARGE" 5257 5265 5242 5501 6742 5566 4601 6560 6001 5542 6350 4600 PARENS, -20 /"PARENTHESIS EXPECTED, NONE SEEN" 6142 6346 5765 5146 6452 6401 4671 6146 4465 4645 1501 5760 5746 0164 4646 5700 / SAMOPT, -11 /"DUPLICATED OPTION" 4566 6155 5244 4265 4645 0160 6165 5260 5700 / BADSIZ, -12 /"ILLEGAL "R" ARGUMENT" 5255 5546 5042 5501 0363 0301 4263 5066 5646 5765 / ILLTYP, -5 /"NOT A OR D" 5760 6501 4201 6063 0145 BADWRD, -12 /"UNRECOGNIZABLE LINE" 6657 6346 4460 5057 5273 4243 5546 0155 5257 4600 / NOCOMA, -15 /"COMMA EXPECTED, NONE SEEN" 4460 5656 4201 4671 6146 4465 4645 1501 5760 5746 0164 4646 5700 / ILLNUM, -10 /"# TOO LARGE OR 0" 0401 6560 6001 5542 6350 4601 6063 0121 / ILLCHR, -17 /"ILLEGAL CHAR IN INITIAL VALUE" 5255 5546 5042 5501 4451 4263 0152 5701 5257 5265 5242 5501 6742 5566 4600 ILLOPT, -15 /"UNKNOWN OR ILLEGAL OPTION" 6657 5457 6070 5701 6063 0152 5555 4650 4255 0101 6061 6552 6057 / ILLSEQ, -30 /"STATEMENTS MISSING, DUPLICATED, OR OUT OF ORDER" 6465 4265 4656 4657 6564 0156 5264 6452 5750 1501 4566 6155 5244 4265 4645 1501 0160 6301 6066 6501 6047 0160 6345 4663 / EMES, -5 /"XX ERRORS" ECNT, 5760 /"NO" OR ## 0146 6363 6063 NOESS, 6401 /GETS ZAPPED OF 1 ERROR / BADTXT, -4 /"BAD TEXT" 4342 4501 6546 7165 FULLUP, -7 /DATA OVERFLOW! 4542 6542 0160 6746 6347 5560 7002 / RECFUL, -20 /"OUTPUT RECORD EXCEEDS 510 CHARS!" 6066 6561 6665 0163 4644 6063 4501 4671 4446 4645 6401 2622 2101 4451 4263 6402 / ILLCOM, -15 /"ILLEGAL OPTION COMBINATION" 5255 5546 5042 5501 6061 6552 6057 0144 6056 4352 5742 6552 6057 / TXTOVR, -7 /"TEXT OVERFLOW!" 6546 7165 0160 6746 6347 5560 7002 HEADER, -44 /"COS 300 FORMS COMPILER VXX XX-XXX-XX DAY PAGE X" 4460 6401 2421 2101 4760 6356 6401 4460 5661 5255 4265 5260 5701 0101 67^100+VERSION+21 0101 0101 DAY, 7171 MT1, 0471 MT2, 7171 1630 YR, 7101 0101 WKDY1, 0101 WKDY2, 0101 0101 0101 0101 0101 0101 0101 0101 0101 6142 5046 PAGENO, 0122 / *3700 LINBUF=. /SOURCE LINES READ INTO HERE *4000 CODBUF=. -10 /THIS WILL FAKE OUT "SAVE" AND RSYS, IN CASE GUY /TRIES TO RUN ONE OF THESE THINGS WITH RSYS 5 /TYPE OF LINE (FOR BENEFIT OR RSYS) -1 /(-) FOR RSYS TO SHOW ASSEMBLY ERRORS 0 /FOR RSYS VERSION /OUR VERSION #, FOR BENEFIT OF "OVERLA" 3 /# OF BLOCKS TO SAVE (0 IF ERRORS) 0 /FOR RSYS 0 /FOR RSYS 0406 /EXTENSION TO USE WITH SAVE (DF) STRTUP, TAD I M4 /GET SYSTEM HANDLER ADDRESS DCA SYSHND TAD I (7773 /GET WIDTH OF PRINTER DCA COLSET TAD P7400 DCA COUNT TAD I (SWITCH AND (7700 TAD (-1600 SNA /IS IT /N FOR NO LISTING? DCA LISTSW /YUP TAD (1600-2400 SZA CLA /IS IT /T FOR TERMINAL OUTPUT? JMP .+3 /NOPE - USE LPT TAD TTYOUT /CHANGE LPT POINTER TO TTY DCA LPOCHR TAD I (SWITCH /NOW CHECK FOR REVERSE AND P77 TAD (-16 SNA //N? DCA LISTSW TAD (16-24 SZA CLA //T? JMP .+3 TAD TTYOUT DCA LPOCHR TAD (RECBUF-1 DCA XR17 CDF 10 TAD (0101 DCA I XR17 /CLEAR RECORD IMAGE TO SPACES ISZ COUNT JMP .-3 CDF 0 TAD (STRTUP-1 DCA XR16 /SET UP POINTER TO WHERE TO START PUTTING CODE TAD (DATBUF-1 DCA XR15 /AND DATA BUFFER TAD I M1 DCA CHAR /SAVE THE DATE IN A CONVENIENT PLACE TAD CHAR AND [-10 TAD (-2010 SZA CLA JMP NOHACK TAD (-26 JMS I KMOVE CDF 0 HACK-1 HEADER-1 JMP I (ENDATE NOHACK, TAD P7 AND CHAR CLL RTL RTL RTL TAD (2301 DCA I (YR TAD CHAR CLL RTR RAR DCA CHAR TAD (37 AND CHAR JMS I KOTOPD DCA I (DAY TAD CHAR CLL RTR RTR RAR AND P17 CLL RAL TAD (MTBL-3 DCA XR14 TAD I XR14 DCA I (MT1 TAD I XR14 DCA I (MT2 JMP I (GETDAY WEEKDY, 6442 /SA 6501 /T 6466 /SU 5701 /N 5660 /MO 5701 /N 6566 /TU 4601 /E 7046 /WE 4501 /D 6551 /TH 6663 /UR 4763 /FR 5201 /I / PAGE /NOW FIGURE OUT DAY OF WEEK /FORMULA IS: / LAST TWO DIGITS OF YEAR / + (INTEGER PART OF LAST TWO DIGITS / 4) / + DAY OF MONTH / + MAGIC # FROM TABLE / ALL DIVIDED BY 7, SAVING THE REMAINDER THEREFROM, / AND REMAINDER OF 0 = SAT, 1 = SUN, ETC. GETDAY, AC7777 7016 CIA TAD .-2 SNA CLA AC4000 TAD I (7604 DCA I (7604 TAD P7 AND I M1 TAD (110 /72 IN DISGUISE DCA NUMBR TAD (3 AND NUMBR SNA CLA /IS IT A LEAP YEAR? JMP LEAP /YES ISZ JAN /NO - FIDDLE TABLE OF MAGIC #S ISZ FEB LEAP, TAD NUMBR CLL RTR /GET YEAR/4 AND (37 DCA TEMP TAD I M1 /GET DAY NOW CLL RTR RAR AND (37 TAD NUMBR /ADD THE MESS TOGETHER TAD TEMP DCA NUMBR TAD I M1 CLL RTL RTL RAL AND P17 TAD (JAN-1 /ADD BASE OF TABLE DCA TEMP TAD I TEMP /GET MAGIC # TAD NUMBR /ADD TO IT LOOP, CLL /NOW DIVIDE BY 7 TAD (-7 /...THE BRUTE FORCE WAY SZL JMP LOOP TAD P7 /FUDGE BACK REMAINDER CLL RAL /MULT BY 2 TAD (WEEKDY-1 /ADD BASE OF TABLE DCA XR14 TAD I XR14 DCA I (WKDY1 TAD I XR14 DCA I (WKDY2 ENDATE, JMP I (REINIT / MTBL, 1653 /-J 4257 /AN 1647 /-F 4643 /EB 1656 /-M 4263 /AR 1642 /-A 6163 /PR 1656 /-M 4272 /AY 1653 /-J 6657 /UN 1653 /-J 6655 /UL 1642 /-A 6650 /UG 1664 /-S 4661 /EP 1660 /-O 4465 /CT 1657 /-N 6067 /OV 1645 /-D 4644 /EC / JAN, 0 /CHANGES TO 1 IF NOT LEAP YEAR FEB, 3 /CHANGES TO 4 IF NOT LEAP YEAR 4 0 2 5 0 3 6 1 4 6 HACK, -25 6551 4257 5401 7260 6601 4760 6301 4366 7252 5750 0144 6064 0124 2121 0116 0165 5146 0142 6665 5160 6364 / PAGE *4400 DATBUF=. FIELD 1 *200 RECBUF=. $-$-$