--- /dev/null
+TITLE READER FOR MUDDLE\r
+\r
+;C. REEVE DEC. 1970\r
+\r
+RELOCA\r
+\r
+READER==1 ;TELL MUDDLE > TO USE SOME SPECIAL HACKS\r
+FRMSIN==1 ;FLAG SAYING WHETHER OR "." AND "'" HACKS EXIST\r
+\r
+.INSRT MUDDLE >\r
+\r
+.GLOBAL CONS,VECTOR,NXTCHR,RLOOKU,CRADIX,SPTIME,QUOTE,TENTAB,CHMAK,FLUSCH,ITENTB\r
+.GLOBAL SETDEV,OPNCHN,ILVAL,RADX,IDVAL,LSTCH,EVECTOR,EUVECTOR,CHUNW\r
+.GLOBAL CHRWRD,EOFCND,DIRECT,ACCESS,IOINS,ROOT,DIRECT,DOIOTI,DOACCS,IGVAL,BYTDOP\r
+.GLOBAL ICONS,INCONS,IEVECT,IEUVEC,BUFSTR,TYPFND,SQUTOA,IBLOCK,GRB\r
+.GLOBAL BADCHN,WRONGD,CHNCLS,FNFFL,IPUT,IGET,ILOC,RXCT,WXCT,IUNWIN,UNWIN2\r
+.GLOBAL CNXTCH,CREADC,MPOPJ,CREDC1,CNXTC1,IREMAS\r
+\r
+BUFLNT==100\r
+\r
+FF=0 ;FALG REGISTER DURING NUMBER CONVERSION\r
+\r
+;FLAGS USED (RIGHT HALF)\r
+\r
+NOTNUM==1 ;NOT A NUMBER\r
+NFIRST==2 ;NOT FIRST CHARACTER BEING READ\r
+DECFRC==4 ;FORCE DECIMAL CONVERSION\r
+NEGF==10 ;NEGATE THIS THING\r
+NUMWIN==20 ;DIGIT(S) SEEN\r
+INSTRN==40 ;IN QUOTED CHARACTER STRING\r
+FLONUM==100 ;NUMBER IS FLOOATING POINT\r
+DOTSEN==200 ;. SEEN IN IMPUT STREAM\r
+EFLG==400 ;E SEEN FOR EXPONENT\r
+IFN FRMSIN,[\r
+ FRSDOT==1000 ;. CAME FIRST\r
+ USEAGN==2000 ;SPECIAL DOT HACK\r
+]\r
+OCTWIN==4000\r
+OCTSTR==10000\r
+\r
+;TEMPORARY OFFSETS\r
+\r
+VCNT==0 ;NUMBER OF ELEMENTS IN CURRENT VECTOR\r
+ONUM==1 ;CURRENT NUMBER IN OCTAL\r
+DNUM==3 ;CURRENT NUMBER IN DECIMAL\r
+FNUM==5 ;CURRENTLY UNUSED\r
+CNUM==7 ;IN CURRENT RADIX\r
+NDIGS==11 ;NUMBER OF DIGITS\r
+ENUM==13 ;EXPONENT\r
+\r
+\r
+\f; TEXT FILE LOADING PROGRAM\r
+\r
+MFUNCTION MLOAD,SUBR,[LOAD]\r
+\r
+ ENTRY\r
+\r
+ HLRZ A,AB ;GET NO. OF ARGS\r
+ CAIE A,-4 ;IS IT 2\r
+ JRST TRY2 ;NO, TRY ANOTHER\r
+ GETYP A,2(AB) ;GET TYPE\r
+ CAIE A,TOBLS ;IS IT OBLIST\r
+ CAIN A,TLIST ; OR LIST THEREOF?\r
+ JRST CHECK1\r
+ JRST WTYP2\r
+\r
+TRY2: CAIE A,-2 ;IS ONE SUPPLIED\r
+ JRST WNA\r
+\r
+CHECK1: GETYP A,(AB) ;GET TYPE\r
+ CAIE A,TCHAN ;IS IT A CHANNEL\r
+ JRST WTYP1\r
+\r
+LOAD1: HLRZ A,TB ;GET CURRENT TIME\r
+ PUSH TP,$TTIME ;AND SAVE IT\r
+ PUSH TP,A\r
+\r
+ MOVEI C,CLSNGO ; LOCATION OF FUNNY CLOSER\r
+ PUSHJ P,IUNWIN ; SET UP AS UNWINDER\r
+\r
+LOAD2: PUSH TP,(AB) ;USE SUPPLIED CHANNEL\r
+ PUSH TP,1(AB)\r
+ PUSH TP,(TB) ;USE TIME AS EOF ARG\r
+ PUSH TP,1(TB)\r
+ CAML AB,[-2,,0] ;CHECK FOR 2ND ARG\r
+ JRST LOAD3 ;NONE\r
+ PUSH TP,2(AB) ;PUSH ON 2ND ARG\r
+ PUSH TP,3(AB)\r
+ MCALL 3,READ\r
+ JRST CHKRET ;CHECK FOR EOF RET\r
+\r
+LOAD3: MCALL 2,READ\r
+CHKRET: CAMN A,(TB) ;IS TYPE EOF HACK\r
+ CAME B,1(TB) ;AND IS VALUE\r
+ JRST EVALIT ;NO, GO EVAL RESULT\r
+ PUSH TP,(AB)\r
+ PUSH TP,1(AB)\r
+ MCALL 1,FCLOSE\r
+ MOVE A,$TCHSTR\r
+ MOVE B,CHQUOTE DONE\r
+ JRST FINIS\r
+\r
+CLSNGO: PUSH TP,$TCHAN\r
+ PUSH TP,1(AB)\r
+ MCALL 1,FCLOSE\r
+ JRST UNWIN2 ; CONTINUE UNWINDING\r
+\r
+EVALIT: PUSH TP,A\r
+ PUSH TP,B\r
+ MCALL 1,EVAL\r
+ JRST LOAD2\r
+\r
+\r
+\r
+; OTHER FILE LOADING PROGRAM\r
+\r
+\r
+\f\r
+MFUNCTION FLOAD,SUBR\r
+\r
+ ENTRY\r
+\r
+ MOVEI C,1 ;INITIALIZE OPEN'S ARG COUNT\r
+ PUSH TP,$TAB ;SLOT FOR SAVED AB\r
+ PUSH TP,[0] ;EMPTY FOR NOW\r
+ PUSH TP,$TCHSTR ;PUT IN FIRST ARG\r
+ PUSH TP,CHQUOTE READ\r
+ MOVE A,AB ;COPY OF ARGUMENT POINTER\r
+\r
+FARGS: JUMPGE A,CALOPN ;DONE? IF SO CALL OPEN\r
+ GETYP B,(A) ;NO, CHECK TYPE OF THIS ARG\r
+ CAIE B,TOBLS ;OBLIST?\r
+ CAIN B,TLIST ; OR LIST THEREOF\r
+ JRST OBLSV ;YES, GO SAVE IT\r
+\r
+ PUSH TP,(A) ;SAVE THESE ARGS\r
+ PUSH TP,1(A)\r
+ ADD A,[2,,2] ;BUMP A\r
+ AOJA C,FARGS ;COUNT AND GO\r
+\r
+OBLSV: MOVEM A,1(TB) ;SAVE THE AB\r
+\r
+CALOPN: ACALL C,FOPEN ;OPEN THE FILE\r
+\r
+ JUMPGE B,FNFFL ;FILE MUST NO EXIST\r
+ EXCH A,(TB) ;PLACE CHANNEL ON STACK\r
+ EXCH B,1(TB) ;OBTAINING POSSIBLE OBLIST\r
+ JUMPN B,2ARGS ;OBLIST SUOPPLIED?\r
+\r
+ MCALL 1,MLOAD ;NO, JUST CALL\r
+ JRST FINIS\r
+\r
+\r
+2ARGS: PUSH TP,(B) ;PUSH THE OBLIST\r
+ PUSH TP,1(B)\r
+ MCALL 2,MLOAD\r
+ JRST FINIS\r
+\r
+\r
+FNFFL: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE FILE-SYSTEM-ERROR\r
+ JUMPE B,CALER1\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ MOVEI A,2\r
+ JRST CALER\r
+\r
+\fMFUNCTION READ,SUBR\r
+\r
+ ENTRY\r
+\r
+ PUSH P,[IREAD1] ;WHERE TO GO AFTER BINDING\r
+READ0: PUSH TP,$TTP ;SLOT FOR LAST THING READ (TYPE IS UNREADABLE)\r
+ PUSH TP,[0]\r
+ PUSH TP,$TFIX ;SLOT FOR RADIX\r
+ PUSH TP,[0]\r
+ PUSH TP,$TCHAN ;AND SLOT FOR CHANNEL\r
+ PUSH TP,[0]\r
+ PUSH TP,[0] ; USER DISP SLOT\r
+ PUSH TP,[0]\r
+ PUSH TP,$TSPLICE\r
+ PUSH TP,[0] ;SEGMENT FOR SPLICING MACROS\r
+ JUMPGE AB,READ1 ;NO ARGS, NO BINDING\r
+ GETYP C,(AB) ;ISOLATE TYPE\r
+ CAIN C,TUNBOU\r
+ JRST WTYP1\r
+ PUSH TP,[TATOM,,-1] ;PUSH THE ATOMS\r
+ PUSH TP,IMQUOTE INCHAN\r
+ PUSH TP,(AB) ;PUSH ARGS\r
+ PUSH TP,1(AB)\r
+ PUSH TP,[0] ;DUMMY\r
+ PUSH TP,[0]\r
+ MOVE B,1(AB) ;GET CHANNEL POINTER\r
+ ADD AB,[2,,2] ;AND ARG POINTER\r
+ JUMPGE AB,BINDEM ;MORE?\r
+ PUSH TP,[TVEC,,-1]\r
+ ADD B,[EOFCND-1,,EOFCND-1]\r
+ PUSH TP,B\r
+ PUSH TP,(AB)\r
+ PUSH TP,1(AB)\r
+ ADD AB,[2,,2]\r
+ JUMPGE AB,BINDEM ;IF ANY MORE ARGS GO PROCESS AND BIND THEM\r
+ GETYP C,(AB) ;ISOLATE TYPE\r
+ CAIE C,TLIST\r
+ CAIN C,TOBLS\r
+ SKIPA\r
+ JRST WTYP3\r
+ PUSH TP,[TATOM,,-1] ;PUSH THE ATOMS\r
+ PUSH TP,IMQUOTE OBLIST\r
+ PUSH TP,(AB) ;PUSH ARGS\r
+ PUSH TP,1(AB)\r
+ PUSH TP,[0] ;DUMMY\r
+ PUSH TP,[0]\r
+ ADD AB,[2,,2] ;AND ARG POINTER\r
+ JUMPGE AB,BINDEM ; ALL DONE, BIND ATOMS\r
+ GETYP 0,(AB) ; GET TYPE OF TABLE\r
+ CAIE 0,TVEC ; SKIP IF BAD TYPE\r
+ JRST WTYP ; ELSE COMPLAIN\r
+ PUSH TP,[TATOM,,-1]\r
+ PUSH TP,IMQUOTE READ-TABLE\r
+ PUSH TP,(AB)\r
+ PUSH TP,1(AB)\r
+ PUSH TP,[0]\r
+ PUSH TP,[0]\r
+ ADD AB,[2,,2] ; BUMP TO NEXT ARG\r
+ JUMPL AB,TMA ;MORE ?, ERROR\r
+BINDEM: PUSHJ P,SPECBIND\r
+ JRST READ1\r
+\r
+MFUNCTION RREADC,SUBR,READCHR\r
+\r
+ ENTRY\r
+ PUSH P,[IREADC]\r
+ JRST READC0 ;GO BIND VARIABLES\r
+\r
+MFUNCTION NXTRDC,SUBR,NEXTCHR\r
+\r
+ ENTRY\r
+\r
+ PUSH P,[INXTRD]\r
+READC0: CAMGE AB,[-5,,]\r
+ JRST TMA\r
+ PUSH TP,(AB)\r
+ PUSH TP,1(AB)\r
+ JUMPL AB,READC1\r
+ MOVE B,IMQUOTE INCHAN\r
+ PUSHJ P,IDVAL\r
+ GETYP A,A\r
+ CAIE A,TCHAN\r
+ JRST BADCHN\r
+ MOVEM A,-1(TP)\r
+ MOVEM B,(TP)\r
+READC1: PUSHJ P,@(P)\r
+ JRST .+2\r
+ JRST FINIS\r
+\r
+ PUSH TP,-1(TP)\r
+ PUSH TP,-1(TP)\r
+ MCALL 1,FCLOSE\r
+ MOVE A,EOFCND-1(B)\r
+ MOVE B,EOFCND(B)\r
+ CAML AB,[-3,,]\r
+ JRST .+3\r
+ MOVE A,2(AB)\r
+ MOVE B,3(AB)\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ MCALL 1,EVAL\r
+ JRST FINIS\r
+\r
+\r
+MFUNCTION PARSE,SUBR\r
+\r
+ ENTRY\r
+\r
+ PUSHJ P,GAPRS ;GET ARGS FOR PARSES\r
+ PUSHJ P,GPT ;GET THE PARSE TABLE\r
+ PUSHJ P,NXTCH ; GET A CHAR TO TEST FOR ! ALT\r
+ SKIPN 11.(TB) ; EOF HIT, COMPLAIN TO LOOSER\r
+ JRST NOPRS\r
+ MOVEI A,33 ; CHANGE IT TO AN ALT, SNEAKY HUH?\r
+ CAIN B,MANYT ; TYPE OF MULTIPLE CLOSE, I.E. ! ALT\r
+ MOVEM A,5(TB)\r
+ PUSHJ P,IREAD1 ;GO DO THE READING\r
+ JRST .+2\r
+ JRST LPSRET ;PROPER EXIT\r
+NOPRS: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE CAN'T-PARSE\r
+ JRST CALER1\r
+\r
+MFUNCTION LPARSE,SUBR\r
+\r
+ ENTRY\r
+\r
+ PUSHJ P,GAPRS ;GET THE ARGS TO THE PARSE\r
+ JRST LPRS1\r
+\r
+GAPRS: PUSH TP,$TTP\r
+ PUSH TP,[0]\r
+ PUSH TP,$TFIX\r
+ PUSH TP,[10.]\r
+ PUSH TP,$TFIX\r
+ PUSH TP,[0] ; LETTER SAVE\r
+ PUSH TP,[0]\r
+ PUSH TP,[0] ; PARSE TABLE MAYBE?\r
+ PUSH TP,$TSPLICE\r
+ PUSH TP,[0] ;SEGMENT FOR SPLICING MACROS\r
+ PUSH TP,[0] ;SLOT FOR LOCATIVE TO STRING\r
+ PUSH TP,[0]\r
+ JUMPGE AB,USPSTR\r
+ PUSH TP,[TATOM,,-1]\r
+ PUSH TP,IMQUOTE PARSE-STRING\r
+ PUSH TP,(AB)\r
+ PUSH TP,1(AB) ; BIND OLD PARSE-STRING\r
+ PUSH TP,[0]\r
+ PUSH TP,[0]\r
+ PUSHJ P,SPECBIND\r
+ ADD AB,[2,,2]\r
+ JUMPGE AB,USPSTR\r
+ GETYP 0,(AB)\r
+ CAIE 0,TFIX\r
+ JRST WTYP2\r
+ MOVE 0,1(AB)\r
+ MOVEM 0,3(TB)\r
+ ADD AB,[2,,2]\r
+ JUMPGE AB,USPSTR\r
+ GETYP 0,(AB)\r
+ CAIE 0,TLIST\r
+ CAIN 0,TOBLS\r
+ SKIPA\r
+ JRST WTYP3\r
+ PUSH TP,[TATOM,,-1]\r
+ PUSH TP,IMQUOTE OBLIST\r
+ PUSH TP,(AB)\r
+ PUSH TP,1(AB) ; HE WANTS HIS OWN OBLIST\r
+ PUSH TP,[0]\r
+ PUSH TP,[0]\r
+ PUSHJ P,SPECBIND\r
+ ADD AB,[2,,2]\r
+ JUMPGE AB,USPSTR\r
+ GETYP 0,(AB)\r
+ CAIE 0,TVEC\r
+ JRST WTYP\r
+ PUSH TP,[TATOM,,-1]\r
+ PUSH TP,IMQUOTE PARSE-TABLE\r
+ PUSH TP,(AB)\r
+ PUSH TP,1(AB)\r
+ PUSH TP,[0]\r
+ PUSH TP,[0]\r
+ PUSHJ P,SPECBIND\r
+ ADD AB,[2,,2]\r
+ JUMPGE AB,USPSTR\r
+ GETYP 0,(AB)\r
+ CAIE 0,TCHRS\r
+ JRST WTYP\r
+ MOVE 0,1(AB)\r
+ MOVEM 0,5(TB) ; STUFF IN A LOOK-AHEAD CHARACTER IF HE WANTS\r
+ ADD AB,[2,,2]\r
+ JUMPL AB,TMA\r
+USPSTR: MOVE B,IMQUOTE PARSE-STRING\r
+ PUSHJ P,ILOC ; GET A LOCATIVE TO THE STRING, WHEREVER\r
+ GETYP 0,A\r
+ CAIN 0,TUNBOUND ; NONEXISTANT\r
+ JRST BDPSTR\r
+ GETYP 0,(B) ; IT IS POINTING TO A STRING\r
+ CAIE 0,TCHSTR\r
+ JRST BDPSTR\r
+ MOVEM A,10.(TB)\r
+ MOVEM B,11.(TB)\r
+ POPJ P,\r
+\r
+LPRS1: PUSHJ P,GPT ; GET THE VALUE OF PARSE-TABLE IN SLOT\r
+ PUSH TP,$TLIST\r
+ PUSH TP,[0] ; HERE WE ARE MAKE PLACE TO SAVE GOODIES\r
+ PUSH TP,$TLIST\r
+ PUSH TP,[0]\r
+LPRS2: PUSHJ P,IREAD1\r
+ JRST LPRSDN ; IF WE ARE DONE, WE ARE THROUGH\r
+ MOVE C,A\r
+ MOVE D,B\r
+ PUSHJ P,INCONS\r
+ SKIPN -2(TP)\r
+ MOVEM B,-2(TP) ; SAVE THE BEGINNING ON FIRST\r
+ SKIPE C,(TP)\r
+ HRRM B,(C) ; PUTREST INTO IT\r
+ MOVEM B,(TP)\r
+ JRST LPRS2\r
+LPRSDN: MOVSI A,TLIST\r
+ MOVE B,-2(TP)\r
+LPSRET: SKIPLE C,5(TB) ; EXIT FOR PARSE AND LPARSE\r
+ CAIN C,400033 ; SEE IF NO PEEK AHEAD OR IF ! ALTMODE\r
+ JRST FINIS ; IF SO NO NEED TO BACK STRING ONE\r
+ SKIPN C,11.(TB)\r
+ JRST FINIS ; IF ATE WHOLE STRING, DONT GIVE BACK ANY\r
+BUPRS: MOVEI D,1\r
+ ADDM D,(C) ; AOS THE COUNT OF STRING LENGTH\r
+ SKIPG D,1(C) ; SEXIER THAN CLR'S CODE FOR DECREMENTING\r
+ SUB D,[430000,,1] ; A BYTE POINTER\r
+ ADD D,[70000,,0]\r
+ MOVEM D,1(C)\r
+ HRRZ E,2(TB)\r
+ JUMPE E,FINIS ; SEE IF WE NEED TO BACK UP TWO\r
+ HLLZS 2(TB) ; CLEAR OUT DOUBLE CHR LOOKY FLAG\r
+ JRST BUPRS ; AND BACK UP PARSE STRING A LITTLE MORE\r
+\r
+\f; ARGUMENTS ARE BOUND, NOW GET THE VALUES OF THINGS\r
+\r
+\r
+GRT: MOVE B,IMQUOTE READ-TABLE\r
+ SKIPA ; HERE TO GET TABLE FOR READ\r
+GPT: MOVE B,IMQUOTE PARSE-TABLE\r
+ MOVSI A,TATOM ; TO FILL SLOT WITH PARSE TABLE\r
+ PUSHJ P,ILVAL\r
+ GETYP 0,A\r
+ CAIN 0,TUNBOUND\r
+ POPJ P,\r
+ CAIE 0,TVEC\r
+ JRST BADPTB\r
+ MOVEM A,6(TB)\r
+ MOVEM B,7(TB)\r
+ POPJ P,\r
+\r
+READ1: PUSHJ P,GRT\r
+ MOVE B,IMQUOTE INCHAN\r
+ MOVSI A,TATOM\r
+ PUSHJ P,IDVAL ;NOW GOBBLE THE REAL CHANNEL\r
+ TLZ A,TYPMSK#777777\r
+ HLLZS A ; INCASE OF FUNNY BUG\r
+ CAME A,$TCHAN ;IS IT A CHANNEL\r
+ JRST BADCHN\r
+ MOVEM A,4(TB) ; STORE CHANNEL\r
+ MOVEM B,5(TB)\r
+ HRRZ A,-4(B)\r
+ TRC A,C.OPN+C.READ\r
+ TRNE A,C.OPN+C.READ\r
+ JRST WRONGD\r
+ HLLOS 4(TB)\r
+ TRNE A,C.BIN ; SKIP IF NOT BIN\r
+ JRST BREAD ; CHECK FOR BUFFER\r
+ HLLZS 4(TB)\r
+GETIOA: MOVE B,5(TB)\r
+GETIO: MOVE A,IOINS(B) ;GOBBLE THE I/O INSTRUCTION\r
+ JUMPE A,OPNFIL ;GO REALLY OPEN THE CROCK\r
+ MOVE A,RADX(B) ;GET RADIX\r
+ MOVEM A,3(TB)\r
+ MOVEM B,5(TB) ;SAVE CHANNEL\r
+REREAD: MOVE D,LSTCH(B) ;ANY CHARS AROUND?\r
+ MOVEI 0,33\r
+ CAIN D,400033 ;FLUSH THE TERMINATOR HACK\r
+ MOVEM 0,LSTCH(B) ; MAKE ! ALT INTO JUST ALT IF IT IS STILL AROUND\r
+\r
+ PUSHJ P,@(P) ;CALL INTERNAL READER\r
+ JRST BADTRM ;LOST\r
+RFINIS: SUB P,[1,,1] ;POP OFF LOSER\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ JUMPE C,FLSCOM ; FLUSH TOP LEVEL COMMENT\r
+ PUSH TP,C\r
+ PUSH TP,D\r
+ MOVE A,4(TB)\r
+ MOVE B,5(TB) ; GET CHANNEL\r
+ MOVSI C,TATOM\r
+ MOVE D,MQUOTE COMMENT\r
+ PUSHJ P,IPUT\r
+RFINI1: POP TP,B\r
+ POP TP,A\r
+ JRST FINIS\r
+\r
+FLSCOM: MOVE A,4(TB)\r
+ MOVE B,5(TB)\r
+ MOVSI C,TATOM\r
+ MOVE D,MQUOTE COMMENT\r
+ PUSHJ P,IREMAS\r
+ JRST RFINI1\r
+\r
+BADTRM: MOVE C,5(TB) ; GET CHANNEL\r
+ JUMPGE B,CHLSTC ;NO, MUST BE UNMATCHED PARENS\r
+ SETZM LSTCH(C) ; DONT REUSE EOF CHR\r
+ PUSH TP,4(TB) ;CLOSE THE CHANNEL\r
+ PUSH TP,5(TB)\r
+ MCALL 1,FCLOSE\r
+ PUSH TP,EOFCND-1(B)\r
+ PUSH TP,EOFCND(B)\r
+ MCALL 1,EVAL ;AND EVAL IT\r
+ SETZB C,D\r
+ GETYP 0,A ; CHECK FOR FUNNY ACT\r
+ CAIE 0,TREADA\r
+ JRST RFINIS ; AND RETURN\r
+\r
+ PUSHJ P,CHUNW ; UNWIND TO POINT\r
+ MOVSI A,TREADA ; SEND MESSAGE BACK\r
+ JRST CONTIN\r
+\r
+;HERE TO ATTEMPT TO OPEN A CLOSED CHANNEL\r
+\r
+OPNFIL: PUSHJ P,OPNCHN ;GO DO THE OPEN\r
+ JUMPGE B,FNFFL ;LOSE IC B IS 0\r
+ JRST GETIO\r
+\r
+\r
+CHLSTC: MOVE B,5(TB) ;GET CHANNEL BACK\r
+ JRST REREAD\r
+\r
+\r
+BREAD: MOVE B,5(TB) ; GET CHANNEL\r
+ SKIPE BUFSTR(B)\r
+ JRST GETIO\r
+ MOVEI A,BUFLNT ; GET A BUFFER\r
+ PUSHJ P,IBLOCK\r
+ MOVEI C,BUFLNT(B) ; POINT TO END\r
+ HRLI C,440700\r
+ MOVE B,5(TB) ; CHANNEL BACK\r
+ MOVEI 0,C.BUF\r
+ IORM 0,-4(B)\r
+ MOVEM C,BUFSTR(B)\r
+ MOVSI C,TCHSTR+.VECT.\r
+ MOVEM C,BUFSTR-1(B)\r
+ JRST GETIO\r
+\f;MAIN ENTRY TO READER\r
+\r
+NIREAD: PUSHJ P,LSTCHR\r
+NIREA1: PUSH P,[-1] ; DONT GOBBLE COMMENTS\r
+ JRST IREAD2\r
+\r
+IREAD:\r
+ PUSHJ P,LSTCHR ;DON'T REREAD LAST CHARACTER\r
+IREAD1: PUSH P,[0] ; FLAG SAYING SNARF COMMENTS\r
+IREAD2: INTGO\r
+BDLP: SKIPE C,9.(TB) ;HAVE WE GOT A SPLICING MACRO LEFT\r
+ JRST SPLMAC ;IF SO GIVE HIM SOME OF IT\r
+ PUSHJ P,NXTCH ;GOBBLE CHAR IN A AND TYPE IN D\r
+ MOVMS B ; FOR SPECIAL NEG HACK OF MACRO TABLES\r
+ CAIG B,ENTYPE\r
+ JUMPN B,@DTBL-1(B) ;ERROR ON ZERO TYPE OR FUNNY TYPE\r
+ JRST BADCHR\r
+\r
+\r
+SPLMAC: HRRZ D,(C) ;GET THE REST OF THE SEGMENT\r
+ MOVEM D,9.(TB) ;AND PUT BACK IN PLACE\r
+ GETYP D,(C) ;SEE IF DEFERMENT NEEDED\r
+ CAIN D,TDEFER\r
+ MOVE C,1(C) ;IF SO, DO DEFEREMENT\r
+ MOVE A,(C)\r
+ MOVE B,1(C) ;GET THE GOODIE\r
+ AOS -1(P) ;ALWAYS A SKIP RETURN\r
+ POP P,(P) ;DONT WORRY ABOUT COMMENT SEARCHAGE\r
+ SETZB C,D ;MAKE SURE HE DOESNT THINK WE GOT COMMENT\r
+ POPJ P, ;GIVE HIM WHAT HE DESERVES\r
+\r
+DTBL: NUMLET ;HERE IF NUMBER OR LETTER\r
+ NUMLET ;NUMBER\r
+NUMCOD==.-DTBL\r
+ NUMLET ;+-\r
+PLUMIN==.-DTBL\r
+ NUMLET ;.\r
+DOTTYP==.-DTBL\r
+ NUMLET ;E\r
+NONSPC==.-DTBL ;NUMBER OF NON-SPECIAL CHARACTERS\r
+ SPACE ;SPACING CHAR CR,LF,SP,TAB ETC.\r
+SPATYP==.-DTBL ;TYPE FOR SPACE CHARS\r
+\r
+\r
+;THE FOLLOWING ENTRIES ARE VARIOUS PUNCTUATION CROCKS\r
+\r
+ LPAREN ;( - BEGIN LIST\r
+ RPAREN ;) - END CURRENT LEVEL OF INPUT\r
+ LBRACK ;[ -BEGIN ARRAY\r
+LBRTYP==.-DTBL\r
+ RBRACK ;] - END OF ARRAY\r
+ QUOTIT ;' - QUOTE THE FOLLOWING GOODIE\r
+QUOTYP==.-DTBL\r
+\r
+ MACCAL ;% - INVOKE A READ TIME MACRO\r
+MACTYP==.-DTBL\r
+ CSTRING ;" - CHARACTER STRING\r
+CSTYP==.-DTBL\r
+ NUMLET ;\ - ESCAPE,BEGIN ATOM\r
+\r
+ESCTYP==.-DTBL ;TYPE OF ESCAPE CHARACTER\r
+\r
+ SPECTY ;# - SPECIAL TYPE TO BE READ\r
+SPCTYP==.-DTBL\r
+ OPNANG ;< - BEGIN ELEMENT CALL\r
+\r
+SLMNT==.-DTBL ;TYPE OF START OF SEGMENT\r
+\r
+ CLSANG ;> - END ELEMENT CALL\r
+\r
+\r
+ EOFCHR ;^C - END OF FILE\r
+\r
+ COMNT ;; - BEGIN COMMENT\r
+COMTYP==.-DTBL ;TYPE OF START OF COMMENT\r
+\r
+ GLOVAL ;, - GET GLOBAL VALUE\r
+GLMNT==.-DTBL\r
+ ILLSQG ;{ - START TEMPLATE STRUCTURE\r
+TMPTYP==.-DTBL\r
+ CLSBRA ;} - END TEMPLATE STRUCTURE\r
+\r
+NTYPES==.-DTBL\r
+\f\r
+\r
+\r
+; EXTENDED TABLE FOR ! HACKS\r
+\r
+ NUMLET ; !! FAKE OUT\r
+ SEGDOT ;!. - CALL TO LVAL (SEG)\r
+DOTEXT==.-DTBL\r
+ UVECIN ;![ - INPUT UNIFORM VECTOR ]\r
+LBREXT==.-DTBL\r
+ QUOSEG ;!' - SEG CALL TO QUOTE\r
+QUOEXT==.-DTBL\r
+ SINCHR ;!" - INPUT ONE CHARACTER\r
+CSEXT==.-DTBL\r
+ SEGIN ;!< - SEG CALL\r
+SLMEXT==.-DTBL\r
+ GLOSEG ;!, - SEG CALL TO GVAL\r
+GLMEXT==.-DTBL\r
+ LOSPATH ;!- - PATH NAME SEPARATOR\r
+PATHTY==.-DTBL\r
+ TERM ;!$ - (EXCAL-ALT MODE) PUT ALL CLOSES\r
+MANYT==.-DTBL\r
+ USRDS1 ; DISPATCH FOR USER TABLE (NO !)\r
+USTYP1==.-DTBL\r
+ USRDS2 ; " " " " (WITH !)\r
+USTYP2==.-DTBL\r
+ENTYPE==.-DTBL\r
+\r
+\r
+\r
+SPACE: PUSHJ P,LSTCHR ;DONT REREAD SPACER\r
+ JRST BDLP\r
+\r
+USRDS1: SKIPA B,A ; GET CHAR IN B \r
+USRDS2: MOVEI B,200(A) ; ! CHAR, DISP 200 FURTHER\r
+ ASH B,1\r
+ ADD B,7(TB) ; POINT TO TABLE ENTRY\r
+ GETYP 0,(B)\r
+ CAIN 0,TLIST\r
+ MOVE B,1(B) ; IF LIST, USE FIRST ITEM-SPECIAL NO BREAK HACK\r
+ SKIPL C,5(TB) ; GET CHANNEL POINTER (IF ANY)\r
+ JRST USRDS3\r
+ ADD C,[EOFCND-1,,EOFCND-1]\r
+ PUSH TP,$TBVL\r
+ HRRM SP,(TP) ; BUILD A TBVL\r
+ MOVE SP,TP\r
+ PUSH TP,C\r
+ PUSH TP,(C)\r
+ PUSH TP,1(C)\r
+ MOVEI D,PVLNT*2+1(PVP)\r
+ HRLI D,TREADA\r
+ MOVEM D,(C)\r
+ MOVEI D,(TB)\r
+ HLL D,OTBSAV(TB)\r
+ MOVEM D,1(C)\r
+USRDS3: PUSH TP,(B) ; APPLIER\r
+ PUSH TP,1(B)\r
+ PUSH TP,$TCHRS ; APPLY TO CHARACTER\r
+ PUSH TP,A\r
+ PUSHJ P,LSTCHR ; FLUSH CHAR\r
+ MCALL 2,APPLY ; GO TO USER GOODIE\r
+ HRRZ SP,(SP) ; UNBIND MANUALLY\r
+ MOVEI D,(TP)\r
+ SUBI D,(SP)\r
+ MOVSI D,(D)\r
+ HLL SP,TP\r
+ SUB SP,D\r
+ SUB TP,[4,,4] ; FLUSH TP CRAP\r
+ GETYP 0,A ; CHECK FOR DISMISS?\r
+ CAIN 0,TSPLICE\r
+ JRST GOTSPL ; RETURN OF SEGMENT INDICATES SPLICAGE\r
+ CAIN 0,TREADA ; FUNNY?\r
+ JRST DOEOF\r
+ CAIE 0,TDISMI\r
+ JRST RET ; NO, RETURN FROM IREAD\r
+ JRST BDLP ; YES, IGNORE RETURN\r
+\r
+GOTSPL: MOVEM B,9.(TB) ; STICK IN THE SPLICAGE SLOT SO IREADS WILL GET HIM\r
+ JRST BDLP ; GO BACK AND READ FROM OUR SPLICE, OK?\r
+\r
+\f\r
+;HERE ON NUMBER OR LETTER, START ATOM\r
+\r
+NUMLET: PUSHJ P,GOBBLE ;READ IN THE ATOM AND PUT PNTR ON ARG PDL\r
+ JRST RET ;NO SKIP RETURN I.E. NON NIL\r
+\r
+;HERE TO START BUILDING A CHARACTER STRING GOODIE\r
+\r
+CSTRING: PUSHJ P,GOBBL1 ;READ IN STRING\r
+ JRST RET\r
+\r
+;ARRIVE HERE TO INVOKE A READ TIME MACRO FUNCTION\r
+\r
+MACCAL: PUSHJ P,NXTCH1 ;READ ONE MORE CHARACTER\r
+ CAIE B,MACTYP ;IS IT ANOTHER MACRO CHAR\r
+\r
+ JRST MACAL2 ;NO, CALL MACRO AND USE VALUE\r
+ PUSHJ P,LSTCHR ;DONT REREAD %\r
+ PUSHJ P,MACAL1 ;OTHERWISE, USE SIDE EFFECCT, BUT NOT VALUE\r
+ JRST IREAD2\r
+\r
+MACAL2: PUSH P,CRET\r
+MACAL1: PUSHJ P,IREAD1 ;READ FUNCTION NAME\r
+ JRST RETERR\r
+ PUSH TP,C\r
+ PUSH TP,D ; SAVE COMMENT IF ANY\r
+ PUSH TP,A ;SAVE THE RESULT\r
+ PUSH TP,B ;AND USE IT AS AN ARGUMENT\r
+ MCALL 1,EVAL\r
+ POP TP,D\r
+ POP TP,C ; RESTORE COMMENT IF ANY...\r
+CRET: POPJ P,RET12\r
+\r
+;CALL GOBBLE TO FIND THE TYPE AND THEN IREAD TO READ IT\r
+\r
+SPECTY: PUSHJ P,NIREAD ; READ THE TYPES NAME (SHOULD BE AN ATOM)\r
+ JRST RETERR\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ PUSHJ P,NXTCH ; GET NEXT CHAR\r
+ CAIN B,TMPTYP ; SKIP IF NOT TEMPLATE START\r
+ JRST RDTMPL\r
+ SETZB A,B\r
+ EXCH A,-1(TP)\r
+ EXCH B,(TP)\r
+ PUSH TP,A ;BEGIN SETTING UP CHTYPE CALL\r
+ PUSH TP,B\r
+ PUSHJ P,IREAD1 ;NOW READ STRUCTURE\r
+ JRST RETER1\r
+ MOVEM C,-3(TP) ; SAVE COMMENT\r
+ MOVEM D,-2(TP)\r
+ EXCH A,-1(TP) ;USE AS FIRST ARG\r
+ EXCH B,(TP)\r
+ PUSH TP,A ;USE OTHER AS 2D ARG\r
+ PUSH TP,B\r
+ MCALL 2,CHTYPE ;ATTEMPT TO MUNG\r
+RET13: POP TP,D\r
+ POP TP,C ; RESTORE COMMENT\r
+RET12: SETOM (P) ; DONT LOOOK FOR MORE!\r
+ JRST RET\r
+\r
+RDTMPL: PUSH P,["}] ; SET UP TERMINATE TEST\r
+ MOVE B,(TP)\r
+ PUSHJ P,IGVAL\r
+ MOVEM A,-1(TP)\r
+ MOVEM B,(TP)\r
+ PUSH P,[BLDTMP] ; FLAG FOR VECTOR READING CODE\r
+ JRST LBRAK2\r
+\r
+BLDTMP: ADDI A,1 ; 1 MORE ARGUMENT\r
+ ACALL A,APPLY ; DO IT TO IT\r
+ POPJ P,\r
+\r
+RETER1: SUB TP,[2,,2]\r
+RETERR: SKIPL A,5(TB)\r
+ MOVEI A,5(TB)-LSTCH ;NO CHANNEL, USE SLOT\r
+ MOVEM B,LSTCH(A) ; RESTORE LAST CHAR\r
+ PUSHJ P,ERRPAR\r
+ JRST RET1\r
+\f\r
+;THIS CODE CALLS IREAD RECURSIVELY TO READ THAT WHICH IS\r
+;BETWEEN (), ARRIVED AT WHEN ( IS READ\r
+\r
+SEGIN: PUSH TP,$TSEG\r
+ JRST OPNAN1\r
+\r
+OPNANG: PUSH TP,$TFORM ;SAVE TYPE\r
+OPNAN1: PUSH P,[">]\r
+ JRST LPARN1\r
+\r
+LPAREN: PUSH P,[")]\r
+ PUSH TP,$TLIST ;START BY ASSUMING NIL\r
+LPARN1: PUSH TP,[0]\r
+ PUSHJ P,LSTCHR ;DON'T REREAD PARENS\r
+LLPLOP: PUSHJ P,IREAD1 ;READ IT\r
+ JRST LDONE ;HIT TERMINATOR\r
+\r
+;HERE WHEN MUST ADD CAR TO CURRENT WINNER\r
+\r
+GENCAR: PUSH TP,C ; SAVE COMMENT\r
+ PUSH TP,D\r
+ MOVE C,A ; SET UP CALL\r
+ MOVE D,B\r
+ PUSHJ P,INCONS ; CONS ON TO NIL\r
+ POP TP,D\r
+ POP TP,C\r
+ POP TP,E ;GET CDR\r
+ JUMPN E,CDRIN ;IF STACKED GOODIE NOT NIL SKIP\r
+ PUSH TP,B ;AND USE AS TOTAL VALUE\r
+ PUSH TP,$TLIST ;SAVE THIS AS FIRSST THING ON LIST\r
+ MOVE A,-2(TP) ; GET REAL TYPE\r
+ JRST .+2 ;SKIP CDR SETTING\r
+CDRIN: HRRM B,(E)\r
+ PUSH TP,B ;CLOBBER IN NEW PARTIAL GOODIE\r
+ JUMPE C,LLPLOP ; JUMP IF NO COMMENT\r
+ PUSH TP,C\r
+ PUSH TP,D\r
+ MOVSI C,TATOM\r
+ MOVE D,MQUOTE COMMENT\r
+ PUSHJ P,IPUT\r
+ JRST LLPLOP ;AND CONTINUE\r
+\r
+; HERE TO RAP UP LIST\r
+\r
+LDONE: CAME B,(P) ;CHECK VALIDITY OF CHARACTER\r
+ PUSHJ P,MISMAT ;REPORT MISMATCH\r
+ SUB P, [1,,1]\r
+ POP TP,B ;GET VALUE OF PARTIAL RESULT\r
+ POP TP,A ;AND TYPE OF SAME\r
+ JUMPE B,RET ;VALUE IS NIL, DON'T POP AGAIN\r
+ POP TP,B ;POP FIRST LIST ELEMENT\r
+ POP TP,A ;AND TYPE\r
+ JRST RET\r
+\f\r
+;THIS CODE IS SIMILAR TO LIST GENERATING CODE BUT IS FOR VECTORS\r
+OPNBRA: PUSH P,["}] ; SAVE TERMINATOR\r
+UVECIN: PUSH P,[135] ; CLOSE SQUARE BRACKET\r
+ PUSH P,[IEUVECTOR] ;PUSH NAME OF U VECT HACKER\r
+ JRST LBRAK2 ;AND GO\r
+\r
+LBRACK: PUSH P,[135] ; SAVE TERMINATE\r
+ PUSH P,[IEVECTOR] ;PUSH GEN VECTOR HACKER\r
+LBRAK2: PUSHJ P,LSTCHR ;FORCE READING NEW CHAR\r
+ PUSH P,[0] ; COUNT ELEMENTS\r
+ PUSH TP,$TLIST ; AND SLOT FOR GOODIES\r
+ PUSH TP,[0]\r
+\r
+LBRAK1: PUSHJ P,IREAD1 ;RECURSIVELY READ ELEMENTS OF ARRAY\r
+ JRST LBDONE ;RAP UP ON TERMINATOR\r
+\r
+STAKIT: EXCH A,-1(TP) ; STORE RESULT AND GET CURRENT LIST\r
+ EXCH B,(TP)\r
+ AOS (P) ; COUNT ELEMENTS\r
+ JUMPE C,LBRAK3 ; IF NO COMMENT, GO ON\r
+ MOVEI E,(B) ; GET CDR\r
+ PUSHJ P,ICONS ; CONS IT ON\r
+ MOVEI E,(B) ; SAVE RS\r
+ MOVSI C,TFIX ; AND GET FIXED NUM\r
+ MOVE D,(P)\r
+ PUSHJ P,ICONS\r
+LBRAK3: PUSH TP,A ; SAVE CURRENT COMMENT LIST\r
+ PUSH TP,B\r
+ JRST LBRAK1\r
+\r
+; HERE TO RAP UP VECTOR\r
+\r
+LBDONE: CAME B,-2(P) ; FINISHED RETURN (WAS THE RIGHT STOP USED?)\r
+ PUSHJ P,MISMAB ; WARN USER\r
+ POP TP,1(TB) ; REMOVE COMMENT LIST\r
+ POP TP,(TB)\r
+ MOVE A,(P) ; COUNT TO A\r
+ PUSHJ P,-1@(P) ; MAKE THE VECTOR\r
+ SUB P,[3,,3] \r
+\r
+; PUT COMMENTS ON VECTOR (OR UVECTOR)\r
+\r
+ MOVNI C,1 ; INDICATE TEMPLATE HACK\r
+ CAMN A,$TVEC\r
+ MOVEI C,1\r
+ CAMN A,$TUVEC ; SKIP IF UVECTOR\r
+ MOVEI C,0\r
+ PUSH P,C ; SAVE\r
+ PUSH TP,A ; SAVE VECTOR/UVECTOR\r
+ PUSH TP,B\r
+\r
+VECCOM: SKIPN C,1(TB) ; ANY LEFT?\r
+ JRST RETVEC ; NO, LEAVE\r
+ MOVE A,1(C) ; ASSUME WINNING TYPES\r
+ SUBI A,1\r
+ HRRZ C,(C) ; CDR THE LIST\r
+ HRRZ E,(C) ; AGAIN\r
+ MOVEM E,1(TB) ; SAVE CDR\r
+ GETYP E,(C) ; CHECK DEFFERED\r
+ MOVSI D,(E)\r
+ CAIN E,TDEFER ; SKIP IF NOT DEFERRED\r
+ MOVE C,1(C)\r
+ CAIN E,TDEFER\r
+ GETYPF D,(C) ; GET REAL TYPE\r
+ MOVE B,(TP) ; GET VECTOR POINTER\r
+ SKIPGE (P) ; SKIP IF NOT TEMPLATE\r
+ JRST TMPCOM\r
+ HRLI A,(A) ; COUNTER\r
+ LSH A,@(P) ; MAYBE SHIFT IT\r
+ ADD B,A\r
+ MOVE A,-1(TP) ; TYPE\r
+TMPCO1: PUSH TP,D\r
+ PUSH TP,1(C) ; PUSH THE COMMENT\r
+ MOVSI C,TATOM\r
+ MOVE D,MQUOTE COMMENT\r
+ PUSHJ P,IPUT\r
+ JRST VECCOM\r
+\r
+TMPCOM: MOVSI A,(A)\r
+ ADD B,A\r
+ MOVSI A,TTMPLT\r
+ JRST TMPCO1\r
+\r
+RETVEC: SUB P,[1,,1]\r
+ POP TP,B\r
+ POP TP,A\r
+ JRST RET\r
+ \r
+; BUILD A SINGLE CHARACTER ITEM\r
+\r
+SINCHR: PUSHJ P,NXTC1 ;FORCE READ NEXT\r
+ CAIN B,ESCTYP ;ESCAPE?\r
+ PUSHJ P,NXTC1 ;RETRY\r
+ MOVEI B,(A)\r
+ MOVSI A,TCHRS\r
+ JRST RETCL\r
+\r
+\f\r
+; HERE ON RIGHT PAREN, BRACKET, ANGLE BRACKET OR CTL C\r
+\r
+CLSBRA:\r
+CLSANG: ;CLOSE ANGLE BRACKETS\r
+RBRACK: ;COMMON RETURN FOR END OF ARRAY ALSO\r
+RPAREN: PUSHJ P,LSTCHR ;DON'T REREAD \r
+EOFCH1: MOVE B,A ;GETCHAR IN B\r
+ MOVSI A,TCHRS ;AND TYPE IN A\r
+RET1: SUB P,[1,,1]\r
+ POPJ P,\r
+\r
+EOFCHR: SETZB C,D\r
+ JUMPL A,EOFCH1 ; JUMP ON REAL EOF\r
+ JRST RRSUBR ; MAYBE A BINARY RSUBR\r
+\r
+DOEOF: MOVE A,[-1,,3]\r
+ SETZB C,D\r
+ JRST EOFCH1\r
+\r
+\r
+; NORMAL RETURN FROM IREAD/IREAD1\r
+\r
+RETCL: PUSHJ P,LSTCHR ;DONT REREAD\r
+RET: AOS -1(P) ;SKIP\r
+ POP P,E ; POP FLAG\r
+RETC: JUMPL E,RET2 ; DONT LOOK FOR COMMENTS\r
+ PUSH TP,A ; SAVE ITEM\r
+ PUSH TP,B\r
+CHCOMN: PUSHJ P,NXTCH ; READ A CHARACTER \r
+ CAIE B,COMTYP ; SKIP IF COMMENT\r
+ JRST CHSPA\r
+ PUSHJ P,IREAD ; READ THE COMMENT\r
+ JRST POPAJ\r
+ MOVE C,A\r
+ MOVE D,B\r
+ JRST .+2\r
+POPAJ: SETZB C,D\r
+ POP TP,B\r
+ POP TP,A\r
+RET2: POPJ P,\r
+\r
+CHSPA: CAIN B,SPATYP\r
+ PUSHJ P,SPACEQ ; IS IT A REAL SPACE\r
+ JRST POPAJ\r
+ PUSHJ P,LSTCHR ; FLUSH THE SPACE\r
+ JRST CHCOMN\r
+\r
+;RANDOM MINI-SUBROUTINES USED BY THE READER\r
+\r
+;READ A CHAR INTO A AND TYPE CODE INTO D\r
+\r
+NXTC1: SKIPL B,5(TB) ;GET CHANNEL\r
+ JRST NXTPR1 ;NO CHANNEL, GO READ STRING\r
+ SKIPE LSTCH(B)\r
+ PUSHJ P,CNTACC ; COUNT ON ACCESS POINTER\r
+ JRST NXTC2\r
+NXTC: SKIPL B,5(TB) ;GET CHANNEL\r
+ JRST NXTPRS ;NO CHANNEL, GO READ STRING\r
+ SKIPE A,LSTCH(B) ;CHAR IN A IF REUSE\r
+ JRST PRSRET\r
+NXTC2: PUSHJ P,RXCT ;GET CHAR FROM INPUT\r
+ HLLZS 2(TB) ;FLAG INDICATING ONE CHAR LOOK AHEAD\r
+ MOVEM A,LSTCH(B) ;SAVE THE CHARACTER\r
+PRSRET: TRZE A,400000 ;DONT SKIP IF SPECIAL\r
+ JRST RETYPE ;GO HACK SPECIALLY\r
+GETCTP: CAILE A,177 ; CHECK RANGE\r
+ JRST BADCHR\r
+ PUSH P,A ;AND SAVE FROM DIVISION\r
+ ANDI A,177\r
+ IDIVI A,CHRWD ;YIELDS WORD AND CHAR NUMBER\r
+ LDB B,BYTPNT(B) ;GOBBLE TYPE CODE\r
+ POP P,A\r
+ POPJ P,\r
+\r
+NXTPRS: SKIPE A,5(TB) ;GET OLD CHARACTER IF ONE EXISTS\r
+ JRST PRSRET\r
+NXTPR1: MOVEI A,400033\r
+ PUSH P,C\r
+ MOVE C,11.(TB)\r
+ HRRZ B,(C) ;GET THE STRING\r
+ SOJL B,NXTPR3\r
+ HRRM B,(C)\r
+ ILDB A,1(C) ;GET THE CHARACTER FROM THE STRING\r
+NXTPR2: MOVEM A,5(TB) ;SAVE IT\r
+ POP P,C\r
+ JRST PRSRET ;CONTINUE\r
+NXTPR3: SETZM 8.(TB)\r
+ SETZM 9.(TB) ;CLEAR OUT LOCATIVE, AT END OF STRING\r
+ JRST NXTPR2\r
+\r
+; NXTCH AND NXTCH1 ARE SAME AS NXTC AND NXTC1 EXCEPT THEY CHECK !\r
+; HACKS\r
+\r
+NXTCH1: PUSHJ P,NXTC1 ;READ CHAR\r
+ JRST .+2\r
+NXTCH: PUSHJ P,NXTC ;READ CHAR\r
+ CAIGE B,NTYPES+1 ;IF 1 > THAN MAX, MUST BE SPECIAL\r
+ JRST CHKUS1 ; CHECK FOR USER DISPATCH\r
+\r
+ CAIN B,NTYPES+1 ;FOR OBSCURE BUG FOUND BY MSG\r
+ PUSHJ P,NXTC1 ;READ NEXT ONE\r
+ HLLOS 2(TB) ;FLAG FOR TWO CHAR LOOK AHEAD\r
+\r
+RETYP1: CAIN A,". ;!.\r
+ MOVEI B,DOTEXT ;YES, GET EXTENDED TYPE\r
+ CAIN A,"[\r
+ MOVEI B,LBREXT\r
+ CAIN A,"'\r
+ MOVEI B,QUOEXT\r
+ CAIN A,""\r
+ MOVEI B,CSEXT\r
+ CAIN A,"-\r
+ MOVEI B,PATHTY\r
+ CAIN A,"<\r
+ MOVEI B,SLMEXT\r
+ CAIN A,",\r
+ MOVEI B,GLMEXT\r
+ CAIN A,33\r
+ MOVEI B,MANYT ;! ALTMODE\r
+\r
+CRMLST: ADDI A,400000 ;CLOBBER LASTCHR\r
+ PUSH P,B\r
+ SKIPL B,5(TB) ;POINT TO CHANNEL\r
+ MOVEI B,5(TB)-LSTCH ;NO CHANNEL, POINT AT SLOT\r
+ MOVEM A,LSTCH(B)\r
+ SUBI A,400000 ;DECREASE CHAR\r
+ POP P,B\r
+\r
+CHKUS2: SKIPN 7(TB) ; SKIP IF USER TABLE\r
+ JRST UPLO\r
+ PUSH P,A\r
+ ADDI A,200\r
+ ASH A,1 ; POINT TO SLOT\r
+ HRLS A\r
+ ADD A,7(TB)\r
+ SKIPL A ;IS THERE VECTOR ENOUGH?\r
+ JRST CHKUS4\r
+ SKIPN 1(A) ; NON-ZERO==>USER FCN EXISTS\r
+ JRST CHKUS4 ; HOPE HE APPRECIATES THIS\r
+ MOVEI B,USTYP2\r
+CHKRDO: PUSH P,0 ; CHECK FOR REDOING IF CHAR IN TABLE\r
+ GETYP 0,(A)\r
+ CAIE 0,TCHRS\r
+ JRST CHKUS5\r
+ POP P,0 ;WE ARE TRANSMOGRIFYING\r
+ POP P,(P) ;FLUSH OLD CHAR\r
+ MOVE A,1(A) ;GET NEW CHARACTER\r
+ PUSH P,7(TB)\r
+ PUSH P,2(TB) ; FLAGS FOR NUM OF CHRS IN LOOK AHEAD\r
+ PUSH P,5(TB) ; TO AVOID SMASHING LSTCHR\r
+ SETZM 5(TB) ; CLEAR OUT CHANNEL\r
+ SETZM 7(TB) ;CLEAR OUT TABLE\r
+ TRZE A,200 ; ! HACK\r
+ TRO A,400000 ; TURN ON PROPER BIT\r
+ PUSHJ P,PRSRET\r
+ POP P,5(TB) ; GET BACK CHANNEL\r
+ POP P,2(TB)\r
+ POP P,7(TB) ;GET BACK OLD PARSE TABLE\r
+ POPJ P,\r
+\r
+CHKUS5: CAIE 0,TLIST\r
+ JRST .+4 ; SPECIAL NON-BREAK TYPE HACK\r
+ MOVNS -1(P) ; INDICATE BY NEGATIVE \r
+ MOVE A,1(A) ; GET <1 LIST>\r
+ GETYP 0,(A) ; AND GET THE TYPE OF THAT\r
+ CAIE 0,TFIX ; SEE IF HE WANTS SAME CHAR WITH DIFF TYPE\r
+ JRST CHKUS6 ; JUST A VANILLA HACK\r
+ MOVE A,1(A) ; PRETEND IT IS SAME TYPE AS NEW CHAR\r
+ PUSH P,7(TB) ; CLEAR OUT TRANSLATE TABLE\r
+ PUSH P,2(TB) ; FLAGS FOR # OF CHRS IN LOOK AHEAD\r
+ SETZM 7(TB)\r
+ TRZE A,200\r
+ TRO A,400000 ; TURN ON PROPER BIT IF ! HACK\r
+ PUSHJ P,PRSRET ; REGET TYPE\r
+ POP P,2(TB)\r
+ POP P,7(TB) ; PUT TRANSLATE TABLE BACK\r
+CHKUS6: SKIPGE -1(P) ; SEE IF A SPECIAL NON-BREAK\r
+ MOVNS B ; SEXY, HUH?\r
+ POP P,0\r
+ POP P,A\r
+ MOVMS A ; FIX UP A POSITIVE CHARACTER\r
+ POPJ P,\r
+\r
+CHKUS4: POP P,A\r
+ JRST UPLO\r
+\r
+CHKUS1: SKIPN 7(TB) ; USER CHECK FOR NOT ! CASE\r
+ POPJ P,\r
+ PUSH P,A\r
+ ASH A,1\r
+ HRLS A\r
+ ADD A,7(TB)\r
+ SKIPL A\r
+ JRST CHKUS3\r
+ SKIPN 1(A)\r
+ JRST CHKUS3\r
+ MOVEI B,USTYP1\r
+ JRST CHKRDO ; TRANSMOGRIFY CHARACTER?\r
+\r
+CHKUS3: POP P,A\r
+ POPJ P,\r
+\r
+UPLO: POPJ P, ; LETS NOT AND SAY WE USED TO\r
+ ; AVOID STRANGE ! BLECHAGE\r
+\r
+RETYPE: PUSHJ P,GETCTP ;GET TYPE OF CHAR\r
+ JRST RETYP1\r
+\r
+NXTCS: PUSHJ P,NXTC\r
+ PUSH P,A ; HACK TO NOT TRANSLATE CHAR\r
+ PUSHJ P,CHKUS1 ; BUT DO TRANSLATION OF TYPE IF HE WANTS\r
+ POP P,A ; USED TO BUILD UP STRINGS\r
+ POPJ P,\r
+\r
+CHKALT: CAIN A,33 ;ALT?\r
+ MOVEI B,MANYT\r
+ JRST CRMLST\r
+\r
+\r
+TERM: MOVEI B,0 ;RETURN A 0\r
+ JRST RET1\r
+ ;AND RETURN\r
+\r
+CHKMIN: CAIN A,"- ; IF CHAR IS -, WINNER\r
+ MOVEI B,PATHTY\r
+ JRST CRMLST\r
+\r
+LOSPAT: PUSHJ P,LSTCHR ; FIX RECURSIVE LOSAGE\r
+ PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE UNATTACHED-PATH-NAME-SEPARATOR\r
+ JRST CALER1\r
+\r
+\f\r
+; HERE TO SEE IF READING RSUBR\r
+\r
+RRSUBR: PUSHJ P,LSTCHR ; FLUSH JUST READ CHAR\r
+ SKIPL B,5(TB) ; SKIP IF A CHANNEL EXISTS\r
+ JRST SPACE ; ELSE LIKE A SPACE\r
+ MOVE C,@BUFSTR(B) ; SEE IF FLAG SAYS START OF RSUBR\r
+ TRNN C,1 ; SKIP IF REAL RSUBR\r
+ JRST SPACE ; NO, IGNORE FOR NOW\r
+\r
+; REALLY ARE READING AN RSUBR\r
+\r
+ HRRZ 0,4(TB) ; GET READ/READB INDICATOR\r
+ MOVE C,ACCESS(B) ; GET CURRENT ACCESS\r
+ JUMPN 0,.+3 ; ALREADY WORDS, NO NEED TO DIVIDE\r
+ ADDI C,4 ; ROUND UP\r
+ IDIVI C,5\r
+ PUSH P,C ; SAVE WORD ACCESS\r
+ MOVEI A,(C) ; COPY IT FOR CALL\r
+ JUMPN 0,.+3\r
+ IMULI C,5\r
+ MOVEM C,ACCESS(B) ; FIXUP ACCESS\r
+ HLLZS ACCESS-1(B) ; FOR READB LOSER\r
+ PUSHJ P,DOACCS ; AND GO THERE\r
+ PUSH P,[0] ; FOR READ IN\r
+ HRROI A,(P) ; PREPARE TO READ LENGTH\r
+ PUSHJ P,DOIOTI ; READ IT\r
+ POP P,C ; GET READ GOODIE\r
+ MOVEI A,(C) ; COPY FOR GETTING BLOCK\r
+ ADDI C,1 ; COUNT COUNT WORD\r
+ ADDM C,(P)\r
+ PUSH TP,$TUVEC ; WILL HOLD UVECTOR OF FIXUPS IF THEY STAY\r
+ PUSH TP,[0]\r
+ PUSHJ P,IBLOCK ; GET A BLOCK\r
+ PUSH TP,$TUVEC\r
+ PUSH TP,B ; AND SAVE\r
+ MOVE A,B ; READY TO IOT IT IN\r
+ MOVE B,5(TB) ; GET CHANNEL BACK\r
+ MOVSI 0,TUVEC ; SETUP A'S TYPE\r
+ MOVEM 0,ASTO(PVP)\r
+ PUSHJ P,DOIOTI ; IN COMES THE WHOLE BLOCK\r
+ SETZM ASTO(PVP) ; A NO LONGER SPECIAL\r
+ MOVEI C,BUFSTR-1(B) ; NO RESET BUFFER\r
+ PUSHJ P,BYTDOP ; A POINTS TO DOPW WORD\r
+ SUBI A,2\r
+ HRLI A,010700 ; SETUP BYTE POINTER TO END\r
+ HLLZS BUFSTR-1(B) ; ZERO CHAR COUNNT\r
+ MOVEM A,BUFSTR(B)\r
+ HRRZ A,4(TB) ; READ/READB FLG\r
+ MOVE C,(P) ; ACCESS IN WORDS\r
+ SKIPN A ; SKIP FOR ASCII\r
+ IMULI C,5 ; BUMP\r
+ MOVEM C,ACCESS(B) ; UPDATE ACCESS\r
+ PUSHJ P,NIREAD ; READ RSUBR VECTOR\r
+ JRST BRSUBR ; LOSER\r
+ GETYP A,A ; VERIFY A LITTLE\r
+ CAIE A,TVEC ; DONT SKIP IF BAD\r
+ JRST BRSUBR ; NOT A GOOD FILE\r
+ PUSHJ P,LSTCHR ; FLUSH REREAD CHAR\r
+ MOVE C,(TP) ; CODE VECTOR BACK\r
+ MOVSI A,TCODE\r
+ HLR A,B ; FUNNY COUNT\r
+ MOVEM A,(B) ; CLOBBER\r
+ MOVEM C,1(B)\r
+ PUSH TP,$TRSUBR ; MAKE RSUBR\r
+ PUSH TP,B\r
+\r
+; NOW LOOK OVER FIXUPS\r
+\r
+ MOVE B,5(TB) ; GET CHANNEL\r
+ MOVE C,ACCESS(B)\r
+ HLLZS ACCESS-1(B) ; FOR READB LOSER\r
+ HRRZ 0,4(TB) ; READ/READB FLG\r
+ JUMPN 0,RSUB1\r
+ ADDI C,4 ; ROUND UP\r
+ IDIVI C,5 ; TO WORDS\r
+ MOVEI D,(C) ; FIXUP ACCESS\r
+ IMULI D,5\r
+ MOVEM D,ACCESS(B) ; AND STORE\r
+RSUB1: ADDI C,1 ; ACCOUNT FOR EXTRA COUNTERS\r
+ MOVEM C,(P) ; SAVE FOR LATER\r
+ MOVEI A,-1(C) ; FOR DOACS\r
+ MOVEI C,2 ; UPDATE REAL ACCESS\r
+ SKIPN 0 ; SKIP FOR READB CASE\r
+ MOVEI C,10.\r
+ ADDM C,ACCESS(B)\r
+ PUSHJ P,DOACCS ; DO THE ACCESS\r
+ PUSH TP,$TUVEC ; SLOT FOR FIXUP BUFFER\r
+ PUSH TP,[0]\r
+\r
+; FOUND OUT IF FIXUPS STAY\r
+\r
+ MOVE B,MQUOTE KEEP-FIXUPS\r
+ PUSHJ P,ILVAL ; GET VALUE\r
+ GETYP 0,A\r
+ MOVE B,5(TB) ; CHANNEL BACK TO B\r
+ CAIE 0,TUNBOU\r
+ CAIN 0,TFALSE\r
+ JRST RSUB4 ; NO, NOT KEEPING FIXUPS\r
+ PUSH P,[0] ; SLOT TO READ INTO\r
+ HRROI A,(P) ; GET LENGTH OF SAME\r
+ PUSHJ P,DOIOTI\r
+ POP P,C\r
+ MOVEI A,(C) ; GET UVECTOR FOR KEEPING\r
+ ADDM C,(P) ; ACCESS TO END\r
+ PUSH P,C ; SAVE LENGTH OF FIXUPS\r
+ PUSHJ P,IBLOCK\r
+ MOVEM B,-6(TP) ; AND SAVE\r
+ MOVE A,B ; FOR IOTING THEM IN\r
+ ADD B,[1,,1] ; POINT PAST VERS #\r
+ MOVEM B,(TP)\r
+ MOVSI C,TUVEC\r
+ MOVEM C,ASTO(PVP)\r
+ MOVE B,5(TB) ; AND CHANNEL\r
+ PUSHJ P,DOIOTI ; GET THEM\r
+ SETZM ASTO(PVP)\r
+ MOVE A,(TP) ; GET VERS\r
+ PUSH P,-1(A) ; AND PUSH IT\r
+ JRST RSUB5\r
+\r
+RSUB4: PUSH P,[0]\r
+ PUSH P,[0] ; 2 SLOTS FOR READING\r
+ MOVEI A,-1(P)\r
+ HRLI A,-2\r
+ PUSHJ P,DOIOTI\r
+ MOVE C,-1(P)\r
+ MOVE D,(P)\r
+ ADDM C,-2(P) ; NOW -2(P) IS ACCESS TO END OF FIXUPS\r
+RSUB5: MOVEI C,BUFSTR-1(B) ; FIXUP BUFFER \r
+ PUSHJ P,BYTDOP\r
+ SUBI A,2 ; POINT BEFORE D.W.\r
+ HRLI A,10700\r
+ MOVEM A,BUFSTR(B)\r
+ HLLZS BUFSTR-1(B)\r
+ SKIPE -6(TP)\r
+ JRST RSUB2A\r
+ SUBI A,BUFLNT-1 ; ALSO MAKE AN IOT FLAVOR BUFFER\r
+ HRLI A,-BUFLNT\r
+ MOVEM A,(TP)\r
+ MOVSI C,TUVEC\r
+ MOVEM C,ASTO(PVP)\r
+ PUSHJ P,DOIOTI\r
+ SETZM ASTO(PVP)\r
+RSUB2A: PUSH P,-1(P) ; ANOTHER COPY OF LENGTH OF FIXUPS\r
+\r
+; LOOP FIXING UP NEW TYPES\r
+\r
+RSUB2: PUSHJ P,WRDIN ; SEE WHAT NEXT THING IS\r
+ JRST RSUB3 ; NO MORE, DONE\r
+ JUMPL E,STSQ ; MUST BE FIRST SQUOZE\r
+ MOVNI 0,(E) ; TO UPDATE AMNT OF FIXUPS\r
+ ADDB 0,(P)\r
+ HRLI E,(E) ; IS LENGTH OF STRING IN WORDS\r
+ ADD E,(TP) ; FIXUP BUFFER POINTER\r
+ JUMPL E,.+3\r
+ SUB E,[BUFLNT,,BUFLNT]\r
+ JUMPGE E,.-1 ; STILL NOT RIGHT\r
+ EXCH E,(TP) ; FIX UP SLOT\r
+ HLRE C,E ; FIX BYTE POINTER ALSO\r
+ IMUL C,[-5] ; + CHARS LEFT\r
+ MOVE B,5(TB) ; CHANNEL\r
+ PUSH TP,BUFSTR-1(B)\r
+ PUSH TP,BUFSTR(B)\r
+ HRRM C,BUFSTR-1(B)\r
+ HRLI E,440700 ; AND BYTE POINTER\r
+ MOVEM E,BUFSTR(B)\r
+ PUSHJ P,NIREAD ; READ ATOM NAME OF TYPE\r
+ TDZA 0,0 ; FLAG LOSSAGE\r
+ MOVEI 0,1 ; WINNAGE\r
+ MOVE C,5(TB) ; RESET BUFFER\r
+ POP TP,BUFSTR(C)\r
+ POP TP,BUFSTR-1(C)\r
+ JUMPE 0,BRSUBR ; BAD READ OF RSUBR\r
+ GETYP A,A ; A LITTLE CHECKING\r
+ CAIE A,TATOM\r
+ JRST BRSUBR\r
+ PUSHJ P,LSTCHR ; FLUSH REREAD CHAR\r
+ HRRZ 0,4(TB) ; FIXUP ACCESS PNTR\r
+ MOVE C,5(TB)\r
+ MOVE D,ACCESS(C)\r
+ HLLZS ACCESS-1(C) ; FOR READB HACKER\r
+ ADDI D,4\r
+ IDIVI D,5\r
+ IMULI D,5\r
+ SKIPN 0\r
+ MOVEM D,ACCESS(C) ; RESET\r
+TYFIXE: PUSHJ P,TYPFND ; SEE IF A LEGAL TYPE NAME\r
+ JRST TYPFIX ; GO SEE USER ABOUT THIS\r
+ PUSHJ P,FIXCOD ; GO FIX UP THE CODE\r
+ JRST RSUB2\r
+\r
+; NOW FIX UP SUBRS ETC. IF NECESSARY\r
+\r
+STSQ: MOVE B,MQUOTE MUDDLE\r
+ PUSHJ P,IGVAL ; GET CURRENT VERS\r
+ CAME B,-1(P) ; SKIP IF NO FIXUPS NEEDED\r
+ JRST DOFIX0 ; MUST DO THEM\r
+\r
+; ALL DONE, ACCESS PAST FIXUPS AND RETURN\r
+\r
+RSUB3: MOVE A,-3(P)\r
+ MOVE B,5(TB)\r
+ MOVEI C,(A) ; UPDATE CHANNEL ACCESS IN CASE SKIPPING\r
+ HRRZ 0,4(TB) ; READ/READB FLAG\r
+ SKIPN 0\r
+ IMULI C,5\r
+ MOVEM C,ACCESS(B) ; INTO ACCESS SLOT\r
+ HLLZS ACCESS-1(B)\r
+ PUSHJ P,DOACCS ; ACCESSED\r
+ MOVEI C,BUFSTR-1(B) ; FIX UP BUFFER\r
+ PUSHJ P,BYTDOP\r
+ SUBI A,2\r
+ HRLI A,10700\r
+ MOVEM A,BUFSTR(B)\r
+ HLLZS BUFSTR-1(B)\r
+ SKIPN A,-6(TP) ; SKIP IF KEEPING FIXUPS\r
+ JRST RSUB6\r
+ PUSH TP,$TUVEC\r
+ PUSH TP,A\r
+ MOVSI A,TRSUBR\r
+ MOVE B,-4(TP)\r
+ MOVSI C,TATOM\r
+ MOVE D,MQUOTE RSUBR\r
+ PUSHJ P,IPUT ; DO THE ASSOCIATION\r
+\r
+RSUB6: MOVE B,-2(TP) ; GET RSUBR\r
+ MOVSI A,TRSUBR\r
+ SUB P,[4,,4] ; FLUSH P CRUFT\r
+ SUB TP,[10,,10]\r
+ JRST RET\r
+\r
+; FIXUP SUBRS ETC.\r
+\r
+DOFIX0: SKIPN C,-6(TP) ; GET BUFFER IF KEEPING\r
+ JRST DOFIXE\r
+ MOVEM B,(C) ; CLOBBER\r
+ JRST DOFIXE\r
+\r
+FIXUPL: PUSHJ P,WRDIN\r
+ JRST RSUB3\r
+DOFIXE: JUMPGE E,BRSUBR\r
+ TLZ E,740000 ; KILL BITS\r
+ PUSHJ P,SQUTOA ; LOOK IT UP\r
+ JRST BRSUBR\r
+ MOVEI D,(E) ; FOR FIXCOD\r
+ PUSHJ P,FIXCOD ; FIX 'EM UP\r
+ JRST FIXUPL\r
+\r
+; ROUTINE TO FIXUP ACTUAL CODE\r
+\r
+FIXCOD: MOVEI E,0 ; FOR HWRDIN\r
+ PUSH P,D ; NEW VALUE\r
+ PUSHJ P,HWRDIN ; GET HW NEEDED\r
+ MOVE D,(P) ; GET NEW VAL\r
+ MOVE A,(TP) ; AND BUFFER POINTER\r
+ SKIPE -6(TP) ; SAVING?\r
+ HRLM D,-1(A) ; YES, CLOBBER\r
+ SUB C,(P) ; DIFFERENCE\r
+ MOVN D,C\r
+\r
+FIXLP: PUSHJ P,HWRDIN ; GET AN OFFSET\r
+ JUMPE C,FIXED\r
+ HRRES C ; MAKE NEG IF NEC\r
+ JUMPL C,LHFXUP\r
+ ADD C,-4(TP) ; POINT INTO CODE\r
+ ADDM D,-1(C)\r
+ JRST FIXLP\r
+\r
+LHFXUP: MOVMS C\r
+ ADD C,-4(TP)\r
+ MOVSI 0,(D)\r
+ ADDM 0,-1(C)\r
+ JRST FIXLP\r
+\r
+FIXED: SUB P,[1,,1]\r
+ POPJ P,\r
+\r
+; ROUTINE TO READ A WORD FROM BUFFER\r
+\r
+WRDIN: PUSH P,A\r
+ PUSH P,B\r
+ SOSG -3(P) ; COUNT IT DOWN\r
+ JRST WRDIN1\r
+ AOS -2(P) ; SKIP RETURN\r
+ MOVE B,5(TB) ; CHANNEL\r
+ HRRZ A,4(TB) ; READ/READB SW\r
+ MOVEI E,5\r
+ SKIPE A\r
+ MOVEI E,1\r
+ ADDM E,ACCESS(B)\r
+ MOVE A,(TP) ; BUFFER\r
+ MOVE E,(A)\r
+ AOBJP A,WRDIN2 ; NEED NEW BUFFER\r
+ MOVEM A,(TP)\r
+WRDIN1: POP P,B\r
+ POP P,A\r
+ POPJ P,\r
+\r
+WRDIN2: MOVE B,-3(P) ; IS THIS LAST WORD?\r
+ SOJLE B,WRDIN1 ; YES, DONT RE-IOT\r
+ SUB A,[BUFLNT,,BUFLNT]\r
+ MOVEM A,(TP)\r
+ MOVSI B,TUVEC\r
+ MOVEM B,ASTO(PVP)\r
+ MOVE B,5(TB)\r
+ PUSHJ P,DOIOTI\r
+ SETZM ASTO(PVP)\r
+ JRST WRDIN1\r
+\r
+; READ IN NEXT HALF WORD\r
+\r
+HWRDIN: JUMPN E,NOIOT ; USE EXISTING WORD\r
+ PUSH P,-3(P) ; FAKE OUT WRDIN IF NEC.\r
+ PUSHJ P,WRDIN\r
+ JRST BRSUBR\r
+ POP P,-4(P) ; RESET COUNTER\r
+ HLRZ C,E ; RET LH \r
+ POPJ P,\r
+\r
+NOIOT: HRRZ C,E\r
+ MOVEI E,0\r
+ POPJ P,\r
+\r
+TYPFIX: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE BAD-TYPE-NAME\r
+ PUSH TP,$TATOM\r
+ PUSH TP,B\r
+ PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE ERRET-TYPE-NAME-DESIRED\r
+ MCALL 3,ERROR\r
+ JRST TYFIXE\r
+\r
+BRSUBR: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE RSUBR-IN-BAD-FORMAT\r
+ JRST CALER1\r
+\f\r
+\r
+\r
+;TABLE OF BYTE POINTERS FOR GETTING CHARS\r
+\r
+BYTPNT": 350700,,CHTBL(A)\r
+ 260700,,CHTBL(A)\r
+ 170700,,CHTBL(A)\r
+ 100700,,CHTBL(A)\r
+ 010700,,CHTBL(A)\r
+\r
+;HERE ARE THE TABLES OF CHXRACTERS (NOTE EVERYTHING NOT SPECIFIED IS\r
+;IN THE NUMBER LETTER CATAGORY)\r
+\r
+SETCHR 2,[0123456789]\r
+\r
+SETCHR 3,[+-]\r
+\r
+SETCHR 4,[.]\r
+\r
+SETCHR 5,[Ee]\r
+\r
+SETCOD 6,[15,12,11,14,40,33] ;ALL ARE TYPE 2 (SPACING - FF,TAB,SPACE,ALT-MODE)\r
+\r
+INCRCH 7,[()[]'%"\#<>] ;GIVE THESE INCREASRNG CODES FROM 3\r
+\r
+SETCOD 22,[3] ;^C - EOF CHARACTER\r
+\r
+INCRCH 23,[;,{}!] ;COMMENT AND GLOBAL VALUE AND SPECIAL\r
+\r
+CHTBL:\r
+ OUTTBL ;OUTPUT THE TABLE RIGHT HERE\r
+\r
+\r
+\f; THIS CODE FLUSHES WANDERING COMMENTS\r
+\r
+COMNT: PUSHJ P,IREAD\r
+ JRST COMNT2\r
+ JRST BDLP\r
+\r
+COMNT2: SKIPL A,5(TB) ; RESTORE CHANNEL\r
+ MOVEI A,5(TB)-LSTCH ;NO CHANNEL, POINT AT SLOT\r
+ MOVEM B,LSTCH(A) ; CLOBBER IN CHAR\r
+ PUSHJ P,ERRPAR\r
+ JRST BDLP\r
+\f\r
+;SUBROUTINE TO READ CHARS ONTO STACK\r
+\r
+GOBBL1: MOVEI FF,0 ;KILL ALL FLAGS\r
+ PUSHJ P,LSTCHR ;DON'T REREAD "\r
+ TROA FF,NOTNUM+INSTRN ;SURPRESS NUMBER CONVERSION\r
+GOBBLE: MOVEI FF,0 ;FLAGS CONCERRNING CURRENT GOODIE IN HERE\r
+ MOVE A,TP ;GOBBLE CURRENT TP TO BE PUSHED\r
+ MOVEI C,6 ;NOW PUSH 6 0'S ON TO STACK\r
+ PUSH TP,$TFIX ;TYPE IS FIXED\r
+ PUSH TP,FF ;AND VALUE IS 0\r
+ SOJG C,.-2 ;FOUR OF THEM\r
+ PUSH TP,$TTP ;NOW SAVE OLD TP\r
+ ADD A,[1,,1] ;MAKE IT LOOK LIKE A TB\r
+ PUSH TP,A\r
+ MOVEI D,0 ;ZERO OUT CHARACTER COUNT\r
+GOB1: MOVSI C,(<440700,,(P)>) ;SET UP FIRST WORD OF CHARS\r
+ PUSH P,[0] ;BYTE POINTER\r
+GOB2: PUSH P,FF ;SAVE FLAG REGISTER\r
+ INTGO ; IN CASE P OVERFLOWS\r
+ MOVEI A,NXTCH\r
+ TRNE FF,INSTRN\r
+ MOVEI A,NXTCS ; HACK TO GET MAYBE NEW TYPE WITHOUT CHANGE\r
+ PUSHJ P,(A)\r
+ POP P,FF ;AND RESTORE FLAG REGISTER\r
+ CAIN B,ESCTYP ;IS IT A CHARACTER TO BE ESCAPED\r
+ JRST ESCHK ;GOBBLE THE ESCAPED CHARACTER\r
+ TRNE FF,INSTRN ;ARE WE BUILDING A CHAR STRING\r
+ JRST ADSTRN ;YES, GO READ IN\r
+ CAILE B,NONSPC ;IS IT SPECIAL\r
+ JRST DONEG ;YES, RAP THIS UP\r
+\r
+ TRNE FF,NOTNUM ;IS NUMERIC STILL WINNING\r
+ JRST SYMB2 ;NO, ONLY DO CHARACTER HACKING\r
+ CAIL A,60 ;CHECK FOR DIGIT\r
+ CAILE A,71\r
+ JRST SYMB1 ;NOT A DIGIT\r
+ JRST CNV ;GO CONVERT TO NUMBER\r
+\fCNV:\r
+\r
+;ARRIVE HERE IF STILL BUILDING A NUMBER\r
+CNV: MOVE B,(TP) ;GOBBLE POINTER TO TEMPS\r
+ TRO FF,NUMWIN ;SAY DIGITSSEEN\r
+ SUBI A,60 ;CONVERT TO A NUMBER\r
+ TRNE FF,EFLG ;HAS E BEEN SEEN\r
+ JRST ECNV ;YES, CONVERT EXPONENT\r
+ TRNE FF,DOTSEN ;HAS A DOT BEEN SEEN\r
+\r
+ JRST DECNV ;YES, THIS IS A FLOATING NUMBER\r
+\r
+ MOVE E,ONUM(B) ; OCTAL CONVERT\r
+ LSH E,3\r
+ ADDI E,(A)\r
+ MOVEM E,ONUM(B)\r
+ TRNE FF,OCTSTR ; SKIP OTHER CONVERSIONS IF OCTAL FORCE\r
+ JRST CNV1\r
+\r
+ JFCL 17,.+1 ;KILL ALL FLAGS\r
+ MOVE E,CNUM(B) ;COMPUTE CURRENT RADIX\r
+ IMUL E,3(TB)\r
+ ADD E,A ;ADD IN CURRENT DIGIT\r
+ JFCL 10,.+2\r
+ MOVEM E,CNUM(B) ;AND SAVE IT\r
+\r
+\r
+\r
+;INSERT OCTAL AND CRADIX CROCK HERE IF NECESSSARY\r
+ JRST DECNV1 ;CONVERT TO DECIMAL(FIXED)\r
+\r
+\r
+DECNV: TRO FF,FLONUM ;SET FLOATING FLAG\r
+DECNV1: JFCL 17,.+1 ;CLEAR ALL FLAGS\r
+ MOVE E,DNUM(B) ;GET DECIMAL NUMBER\r
+ IMULI E,10.\r
+ JFCL 10,CNV2 ;JUMP IF OVERFLOW\r
+ ADD E,A ;ADD IN DIGIT\r
+ MOVEM E,DNUM(B)\r
+ TRNE FF,FLONUM ;IS THIS FRACTION?\r
+ SOS NDIGS(B) ;YES, DECREASE EXPONENT BY ONE\r
+\r
+CNV1: PUSHJ P,NXTCH ;RE-GOBBLE CHARACTER\r
+ JRST SYMB2 ;ALSO DEPOSIT INTO SYMBOL BEING MADE\r
+CNV2: ;OVERFLOW IN DECIMAL NUMBER\r
+ TRNE FF,DOTSEN ;IS THIS FRACTION PART?\r
+ JRST CNV1 ;YES,IGNORE DIGIT\r
+ AOS NDIGS(B) ;NO, INCREASE IMPLICIT EXPONENT BY ONE\r
+ TRO FF,FLONUM ;SET FLOATING FLAG BUT \r
+ JRST CNV1 ;DO NOT FORCE DECIMAL(DECFRC)\r
+\r
+ECNV: ;CONVERT A DECIMAL EXPONENT\r
+ HRRZ E,ENUM(B) ;GET EXPONENT\r
+ IMULI E,10.\r
+ ADD E,A ;ADD IN DIGIT\r
+ TLNN E,777777 ;IF OVERFLOW INTO LEFT HALF\r
+ HRRM E,ENUM(B) ;DO NOT STORE(CATCH ERROR LATER)\r
+ JRST CNV1\r
+ JRST SYMB2 ;ALSO DEPOSIT INTO SYMBOL BEING MADE\r
+\r
+\f\r
+;HERE TO PUT INTO IDENTIFIER BEING BUILT\r
+\r
+ESCHK: PUSHJ P,NXTC1 ;GOBBLE NEXT CHAR\r
+SYMB: MOVE B,(TP) ;GET BACK TEM POINTER\r
+ TRNE FF,EFLG ;IF E FLAG SET\r
+ HLRZ FF,ENUM(B) ;RESTORE SAVED FLAGS\r
+ TRO FF,NOTNUM ;SET NOT NUMBER FLAG\r
+SYMB2: TRO FF,NFIRST ;NOT FIRST IN WORLD\r
+SYMB3: IDPB A,C ;INSERT IT\r
+ PUSHJ P,LSTCHR ;READ NEW CHARACTER\r
+ TLNE C,760000 ;WORD FULL?\r
+ AOJA D,GOB2 ;NO, KEEP TRYING\r
+ AOJA D,GOB1 ;COUNT WORD AND GO\r
+\r
+;HERE TO CHECK FOR +,-,. IN NUMBER\r
+\r
+SYMB1: TRNE FF,NFIRST ;IS THIS THE FIRST CHARACTER\r
+ JRST CHECK. ;NO, ONLY LOOK AT DOT\r
+ CAIE A,"- ;IS IT MINUS\r
+ JRST .+3 ;NO CHECK PLUS\r
+ TRO FF,NEGF ;YES, NEGATE AT THE END\r
+ JRST SYMB2\r
+ CAIN A,"+ ;IS IT +\r
+ JRST SYMB2 ;ESSENTIALLY IGNORE IT\r
+ CAIE A,"* ; FUNNY OCTAL CROCK?\r
+ JRST CHECK.\r
+\r
+ TRO FF,OCTSTR\r
+ JRST SYMB2\r
+\r
+;COULD BE .\r
+\r
+CHECK.: PUSHJ P,LSTCHR ;FLUSH LAST CHARACTER\r
+ MOVEI E,0\r
+ TRNN FF,DOTSEN+EFLG ;IF ONE ALREADY SEEN\r
+ CAIE A,".\r
+ JRST CHECKE ;GO LOOK FOR E\r
+\r
+IFN FRMSIN,[\r
+ TRNN FF,NFIRST ;IS IT THE FIRST\r
+ JRST DOT1 ;YES, COULD MEAN EVALUATE A VARIABLE\r
+]\r
+\r
+CHCK.1: TRO FF,DECFRC+DOTSEN ;FORCE DECIMAL \r
+IFN FRMSIN, TRNN FF,FRSDOT ;IF NOT FIRST ., PUT IN CHAR STRING\r
+ JRST SYMB2 ;ENTER INTO SYMBOL\r
+IFN FRMSIN, JRST GOB2 ;IGNORE THE "."\r
+\f\r
+\r
+\r
+IFN FRMSIN,[\r
+\r
+;HERE TO SET UP FOR .FOO ..FOO OR.<ABC>\r
+\r
+DOT1: PUSH P,FF ;SAVE FLAGS\r
+ PUSHJ P,NXTCH1 ;GOBBLE A NEW CHARACTER\r
+ POP P,FF ;RESTORE FLAGS\r
+ TRO FF,FRSDOT ;SET FLAG IN CASE\r
+ CAIN B,NUMCOD ;SKIP IF NOT NUMERIC\r
+ JRST CHCK.1 ;NUMERIC, COULD BE FLONUM\r
+\r
+; CODE TO HANDLE ALL IMPLICIT CALLS I.E. QUOTE, LVAL, GVAL\r
+\r
+ MOVSI B,TFORM ;LVAL\r
+ MOVE A,MQUOTE LVAL\r
+ SUB P,[2,,2] ;POP OFF BYTE POINTER AND GOBBLE CALL\r
+ POP TP,TP\r
+ SUB TP,[1,,1] ;REMOVE TP JUNK\r
+ JRST IMPCA1\r
+\r
+GLOSEG: SKIPA B,$TSEG ;SEG CALL TO GVAL\r
+GLOVAL: MOVSI B,TFORM ;FORM CALL TO SAME\r
+ MOVE A,MQUOTE GVAL\r
+ JRST IMPCAL\r
+\r
+QUOSEG: SKIPA B,$TSEG ;SEG CALL TO QUOTE\r
+QUOTIT: MOVSI B,TFORM\r
+ MOVE A,MQUOTE QUOTE\r
+ JRST IMPCAL\r
+\r
+SEGDOT: MOVSI B,TSEG ;SEG CALL TO LVAL\r
+ MOVE A,MQUOTE LVAL\r
+IMPCAL: PUSHJ P,LSTCHR ;FLUSH LAST CHAR EXCEPT\r
+IMPCA1: PUSH TP,$TATOM ;FOR .FOO FLAVOR\r
+ PUSH TP,A ;PUSH ARGS\r
+ PUSH P,B ;SAVE TYPE\r
+ PUSHJ P,IREAD1 ;READ\r
+ JRST USENIL ; IF NO ARG, USE NIL\r
+IMPCA2: PUSH TP,C\r
+ PUSH TP,D\r
+ MOVE C,A ; GET READ THING\r
+ MOVE D,B\r
+ PUSHJ P,INCONS ; CONS TO NIL\r
+ MOVEI E,(B) ; PREPARE TON CONS ON\r
+POPARE: POP TP,D ; GET ATOM BACK\r
+ POP TP,C\r
+ EXCH C,-1(TP) ; SAVE THAT COMMENT\r
+ EXCH D,(TP)\r
+ PUSHJ P,ICONS\r
+ POP P,A ;GET FINAL TYPE\r
+ JRST RET13 ;AND RETURN\r
+\r
+\r
+USENIL: PUSH TP,C\r
+ PUSH TP,D\r
+ SKIPL A,5(TB) ; RESTOR LAST CHR\r
+ MOVEI A,5(TB)-LSTCH ;NO CHANNEL, POINT AT SLOT\r
+ MOVEM B,LSTCH(A)\r
+ MOVEI E,0\r
+ JRST POPARE\r
+\f\r
+;HERE AFTER READING ATOM TO CALL VALUE\r
+\r
+.SET: SUB P,[1,,1] ;FLUSH GOBBLE CALL\r
+ PUSH P,$TFORM ;GET WINNING TYPE\r
+ MOVE E,(P)\r
+ PUSHJ P,RETC ; CHECK FOR POSSIBLE COMMENT\r
+ PUSH TP,$TATOM\r
+ PUSH TP,MQUOTE LVAL\r
+ JRST IMPCA2 ;GO CONS LIST\r
+\r
+]\r
+\r
+;HERE TO CHECK FOR "E" FLAVOR OF EXPONENT\r
+\r
+CHECKE: CAIN A,"* ; CHECK FOR FINAL *\r
+ JRST SYMB4\r
+ TRNN FF,EFLG ;HAS ONE BEEN SEEN\r
+ CAIE B,NONSPC ;IF NOT, IS THIS ONE\r
+ JRST SYMB ;NO, ENTER AS SYMBOL KILL NUMERIC WIN\r
+\r
+ TRNN FF,NUMWIN ;HAVE DIGITS BEEN SEEN?\r
+ JRST SYMB ;NO, NOT A NUMBER\r
+ MOVE B,(TP) ;GET POINTER TO TEMPS\r
+ HRLM FF,ENUM(B) ;SAVE FLAGS\r
+ HRRI FF,DECFRC+DOTSEN+EFLG ;SET NEW FLAGS\r
+ JRST SYMB3 ;ENTER SYMBOL\r
+\r
+\r
+SYMB4: TRZN FF,OCTSTR\r
+ JRST SYMB\r
+ TRZN FF,OCTWIN ; ALREADY WON?\r
+ TROA FF,OCTWIN ; IF NOT DO IT NOW\r
+ JRST SYMB\r
+ JRST SYMB2\r
+\r
+;HERE ON READING CHARACTER STRING\r
+\r
+ADSTRN: SKIPL A ; EOF?\r
+ CAIN B,MANYT ;TERMINATE?\r
+ JRST DONEG ;YES\r
+ CAIE B,CSTYP\r
+ JRST SYMB2 ;NO JUST INSERT IT\r
+ADSTN1: PUSHJ P,LSTCHR ;DON'T REREAD """\r
+\r
+\f\r
+;HERE TO FINISH THIS CROCK\r
+\r
+DONEG: TRNN FF,OCTSTR ; IF START OCTAL BUT NOT FINISH..\r
+ TRNN FF,NUMWIN ;HAVE DIGITS BEEN SEEN?\r
+ TRO FF,NOTNUM ;NO,SET NOT NUMBER FLAG\r
+ SKIPGE C ; SKIP IF STUFF IN TOP WORD\r
+ SUB P,[1,,1]\r
+ PUSH P,D\r
+ TRNN FF,NOTNUM ;NUMERIC?\r
+ JRST NUMHAK ;IS NUMERIC, GO TO IT\r
+\r
+IFN FRMSIN,[\r
+ MOVE A,(TP) ;GET POINTER TO TEMPS\r
+ MOVEM FF,NDIGS(A) ;USE TO HOLD FLAGS\r
+]\r
+ TRNE FF,INSTRN ;ARE WE BUILDING A STRING\r
+ JRST MAKSTR ;YES, GO COMPLETE SAME\r
+LOOPAT: PUSHJ P,NXTCH ; CHECK FOR TRAILER\r
+ CAIN B,PATHTY ; PATH BEGINNER\r
+ JRST PATH0 ; YES, GO PROCESS\r
+ CAIN B,SPATYP ; SPACER?\r
+ PUSHJ P,SPACEQ ; CHECK FOR REAL SPACE\r
+ JRST PATH2\r
+ PUSHJ P,LSTCHR ; FLUSH IT AND RETRY\r
+ JRST LOOPAT\r
+PATH0: PUSHJ P,NXTCH1 ; READ FORCED NEXT\r
+ CAIE B,SPCTYP ; DO #FALSE () HACK\r
+ CAIN B,ESCTYP\r
+ JRST PATH4\r
+ CAIL B,SPATYP ; SPACER?\r
+ JRST PATH3 ; YES, USE THE ROOT OBLIST\r
+PATH4: PUSHJ P,NIREA1 ; READ NEXT ITEM\r
+ PUSHJ P,ERRPAR ; LOSER\r
+ CAME A,$TATOM ; ONLY ALLOW ATOMS\r
+ JRST BADPAT\r
+\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ PUSH TP,$TATOM\r
+ PUSH TP,IMQUOTE OBLIST\r
+ MCALL 2,GET ; GET THE OBLIST\r
+ CAMN A,$TOBLS ; IF NOT OBLIST, MAKE ONE\r
+ JRST PATH6\r
+ MCALL 1,MOBLIS ; MAKE ONE\r
+ JRST PATH1\r
+\r
+PATH6: SUB TP,[2,,2]\r
+ JRST PATH1\r
+\r
+\r
+PATH3: MOVE B,ROOT+1(TVP) ; GET ROOT OBLIST\r
+ MOVSI A,TOBLS\r
+PATH1: PUSHJ P,RLOOKU ; AND LOOK IT UP\r
+\r
+IFN FRMSIN,[\r
+ MOVE C,(TP) ;SET TO REGOBBLE FLAGS\r
+ MOVE FF,NDIGS(C)\r
+]\r
+ JRST FINID\r
+\r
+\r
+SPACEQ: ANDI A,-1\r
+ CAIE A,33\r
+ CAIN A,400033\r
+ POPJ P,\r
+ CAIE A,3\r
+ AOS (P)\r
+ POPJ P,\r
+\f\r
+;HERE TO RAP UP CHAR STRING ITEM\r
+\r
+MAKSTR: MOVE C,D ;SETUP TO CALL CHMAK\r
+ PUSHJ P,CHMAK ;GO MAKE SAME\r
+ JRST FINID\r
+\r
+\r
+NUMHAK: MOVE C,(TP) ;REGOBBLETEMP POINTER\r
+ POP P,D ;POP OFF STACK TOP\r
+ ADDI D,4\r
+ IDIVI D,5\r
+ HRLI D,(D) ;TOO BOTH HALVES\r
+ SUB P,D ;REMOVE CHAR STRING\r
+ TRNE FF,FLONUM+EFLG ;IS IT A FLOATING POINT NUMBER\r
+ JRST FLOATIT ;YES, GO MAKE IT WIN\r
+ MOVE B,CNUM(C)\r
+ TRNE FF,DECFRC\r
+ MOVE B,DNUM(C) ;GRAB FIXED GOODIE\r
+ TRNE FF,OCTWIN ; SKIP IF NOT OCTAL\r
+ MOVE B,ONUM(C) ; USE OCTAL VALUE\r
+\r
+FINID2: MOVSI A,TFIX ;SAY FIXED POINT\r
+FINID1: TRNE FF,NEGF ;NEGATE\r
+ MOVNS B ;YES\r
+FINID: POP TP,TP ;RESTORE OLD TP\r
+ SUB TP,[1,,1] ;FINISH HACK\r
+IFN FRMSIN,[\r
+ TRNE FF,FRSDOT ;DID . START IT\r
+ JRST .SET ;YES, GO HACK\r
+]\r
+ POPJ P, ;AND RETURN\r
+\r
+\r
+\r
+\r
+PATH2: MOVE B,IMQUOTE OBLIST\r
+ PUSHJ P,IDVAL\r
+ JRST PATH1\r
+\r
+BADPAT: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE NON-ATOMIC-OBLIST-NAME\r
+ JRST CALER1\r
+\r
+\f\r
+FLOATIT:\r
+ JFCL 17,.+1 ;CLEAR ALL ARITHMETIC FLAGS\r
+\r
+ TRNE FF,EFLG ;"E" SEEN?\r
+ JRST EXPDO ;YES, DO EXPONENT\r
+ MOVE D,NDIGS(C) ;GET IMPLICIT EXPONENT\r
+\r
+FLOATE: MOVE A,DNUM(C) ;GET DECIMAL NUMBER\r
+ IDIVI A,400000 ;SPLIT\r
+ FSC A,254 ;CONVERT MOST SIGNIFICANT\r
+ FSC B,233 ; AND LEAST SIGNIFICANT\r
+ FADR B,A ;COMBINE\r
+\r
+ MOVM A,D ;GET MAGNITUDE OF EXPONENT \r
+ CAILE A,37. ;HOW BIG?\r
+ JRST FOOR ;TOO BIG-FLOATING OUT OF RANGE\r
+ JUMPGE D,FLOAT1 ;JUMP IF EXPONENT POSITIVE\r
+ FDVR B,TENTAB(A) ;DIVIDE BY TEN TO THE EXPONENT\r
+ JRST SETFLO\r
+\r
+FLOAT1: FMPR B,TENTAB(A) ;SCALE UP\r
+\r
+SETFLO: JFCL 10,FOOR ;FLOATING OUT OF RANGE ON OVERFLOW\r
+ MOVSI A,TFLOAT\r
+IFN FRMSIN, TRZ FF,FRSDOT ;FLOATING NUMBER NOT VALUE\r
+ JRST FINID1\r
+\r
+EXPDO:\r
+ HRRZ D,ENUM(C) ;GET EXPONENT\r
+ TRNE FF,NEGF ;IS EXPONENT NEGATIVE?\r
+ MOVNS D ;YES\r
+ ADD D,NDIGS(C) ;ADD IMPLICIT EXPONENT\r
+ HLR FF,ENUM(C) ;RESTORE FLAGS\r
+ JUMPL D,FLOATE ;FLOATING IF EXPONENT NEGATIVE\r
+ CAIG D,10. ;OR IF EXPONENT TOO LARGE\r
+ TRNE FF,FLONUM ;OR IF FLAG SET\r
+ JRST FLOATE\r
+ MOVE B,DNUM(C) ;\r
+ IMUL B,ITENTB(D) \r
+ JFCL 10,FLOATE ;IF OVERFLOW, MAKE FLOATING\r
+ JRST FINID2 ;GO MAKE FIXED NUMBER\r
+\f\r
+; HERE TO READ ONE CHARACTER FOR USER.\r
+\r
+CREDC1: SUBM M,(P)\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ PUSHJ P,IREADC\r
+ JFCL\r
+ JRST MPOPJ\r
+\r
+CNXTC1: SUBM M,(P)\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ PUSHJ P,INXTRD\r
+ JFCL\r
+ JRST MPOPJ\r
+\r
+CREADC: SUBM M,(P)\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ PUSHJ P,IREADC\r
+ JRST RMPOPJ\r
+ SOS (P)\r
+ JRST RMPOPJ\r
+\r
+CNXTCH: SUBM M,(P)\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ PUSHJ P,INXTRD\r
+ JRST RMPOPJ\r
+ SOS (P)\r
+RMPOPJ: SUB TP,[2,,2]\r
+ JRST MPOPJ\r
+\r
+INXTRD: TDZA E,E\r
+IREADC: MOVEI E,1\r
+ MOVE B,(TP) ; CHANNEL\r
+ HRRZ A,-4(B) ; GET BLESS BITS\r
+ TRNE A,C.BIN\r
+ TRNE A,C.BUF\r
+ JRST .+3\r
+ PUSHJ P,GRB\r
+ HRRZ A,-4(B)\r
+ TRC A,C.OPN+C.READ\r
+ TRNE A,C.OPN+C.READ\r
+ JRST BADCHN\r
+ SKIPN A,LSTCH(B)\r
+ PUSHJ P,RXCT\r
+ MOVEM A,LSTCH(B) ; SAVE CHAR\r
+ CAMN A,[-1] ; SPECIAL PSEUDO TTY HACK?\r
+ JRST PSEUDO ; YES, RET AS FIX\r
+ TRZN A,400000 ; UNDO ! HACK\r
+ JRST NOEXCL\r
+ SKIPE E\r
+ MOVEM A,LSTCH(B)\r
+ MOVEI A,"! ; RETURN AN !\r
+NOEXC1: SKIPGE B,A ; CHECK EOF\r
+ SOS (P) ; DO EOF RETURN\r
+ MOVE B,A ; CHAR TO B\r
+ MOVSI A,TCHRS\r
+PSEUD1: AOS (P)\r
+ POPJ P,\r
+\r
+PSEUDO: SKIPE E\r
+ PUSHJ P,LSTCH2\r
+ MOVE B,A\r
+ MOVSI A,TFIX\r
+ JRST PSEUD1\r
+\r
+NOEXCL: SKIPE E\r
+ PUSHJ P,LSTCH2\r
+ JRST NOEXC1\r
+\r
+; READER ERRORS COME HERE\r
+\r
+ERRPAR: PUSH TP,$TCHRS ;DO THE OFFENDER\r
+ PUSH TP,B\r
+ PUSH TP,$TCHRS\r
+ PUSH TP,[40] ;SPACE\r
+ PUSH TP,$TCHSTR\r
+ PUSH TP,CHQUOT UNEXPECTED\r
+ JRST MISMA1\r
+\r
+;COMPLAIN ABOUT MISMATCHED CLOSINGS\r
+\r
+MISMAB: SKIPA A,["]]\r
+MISMAT: MOVE A,-1(P) ;GOBBLE THE DESIRED CHARACTER\r
+ JUMPE B,CPOPJ ;IGNORE UNIVERSAL CLOSE\r
+ PUSH TP,$TCHRS\r
+ PUSH TP,B\r
+ PUSH TP,$TCHSTR\r
+ PUSH TP,CHQUOT [ INSTEAD-OF ]\r
+ PUSH TP,$TCHRS\r
+ PUSH TP,A\r
+MISMA1: MCALL 3,STRING\r
+ PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE READER-SYNTAX-ERROR-ERRET-ANYTHING-TO-GO-ON\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ PUSH TP,$TATOM\r
+ PUSH TP,MQUOTE READ\r
+ MCALL 3,ERROR\r
+CPOPJ: POPJ P,\r
+\f\r
+; HERE ON BAD INPUT CHARACTER\r
+\r
+BADCHR: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE BAD-ASCII-CHARACTER\r
+ JRST CALER1\r
+\r
+; HERE ON YUCKY PARSE TABLE\r
+\r
+BADPTB: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE BAD-MACRO-TABLE\r
+ JRST CALER1\r
+\r
+BDPSTR: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE BAD-PARSE-STRING\r
+ JRST CALER1\r
+\r
+ILLSQG: PUSHJ P,LSTCHR ; DON'T MESS WITH IT AGAIN\r
+ PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE BAD-USE-OF-SQUIGGLY-BRACKETS\r
+ JRST CALER1\r
+\r
+\r
+;FLOATING POINT NUMBER TOO LARGE OR SMALL\r
+FOOR: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE NUMBER-OUT-OF-RANGE\r
+ JRST CALER1\r
+\r
+\r
+NILSXP: 0,,0\r
+\r
+LSTCHR: PUSH P,B\r
+ SKIPL B,5(TB) ;GET CHANNEL\r
+ JRST LSTCH1 ;NO CHANNEL, POINT AT SLOT\r
+ PUSHJ P,LSTCH2\r
+ POP P,B\r
+ POPJ P,\r
+\r
+LSTCH2: SKIPE LSTCH(B) ;ARE WE REALLY FLUSHING A REUSE CHARACTER ?\r
+ PUSHJ P,CNTACC\r
+ SETZM LSTCH(B)\r
+ POPJ P,\r
+\r
+LSTCH1: SETZM 5(TB) ;ZERO THE LETTER AND RETURN\r
+ POP P,B\r
+ POPJ P,\r
+\r
+CNTACC: PUSH P,A\r
+ HRRZ A,-4(B) ; GET BITS\r
+ TRNE A,C.BIN\r
+ JRST CNTBIN\r
+ AOS ACCESS(B)\r
+CNTDON: POP P,A\r
+ POPJ P,\r
+\r
+CNTBIN: AOS A,ACCESS-1(B)\r
+ CAMN A,[TFIX,,1]\r
+ AOS ACCESS(B)\r
+ CAMN A,[TFIX,,5]\r
+ HLLZS ACCESS-1(B)\r
+ JRST CNTDON\r
+\r
+\r
+;TABLE OF NAMES OF ARGS AND ALLOWED TYPES\r
+\r
+ARGS:\r
+ IRP A,,[[[CAIN C,TUNBOU]],[[CAIE C,TCHAN],INCHAN],[[PUSHJ P,CHOBL],OBLIST]]\r
+ IRP B,C,[A]\r
+ B\r
+ IFSN [C],IMQUOTE C\r
+ .ISTOP\r
+ TERMIN\r
+ TERMIN\r
+\r
+CHOBL: CAIE C,TLIST ;A LIST OR AN OBLIST\r
+ CAIN C,TOBLS\r
+ AOS (P)\r
+ POPJ P,\r
+\r
+END\r
+\r
+\f
\ No newline at end of file
projects / pdp10-muddle.git / blobdiff