TITLE READER FOR MUDDLE ;C. REEVE DEC. 1970 RELOCA READER==1 ;TELL MUDDLE > TO USE SOME SPECIAL HACKS FRMSIN==1 ;FLAG SAYING WHETHER OR "." AND "'" HACKS EXIST .INSRT MUDDLE > .GLOBAL CONS,VECTOR,NXTCHR,RLOOKU,CRADIX,SPTIME,QUOTE,TENTAB,CHMAK,FLUSCH,ITENTB .GLOBAL SETDEV,OPNCHN,ILVAL,RADX,IDVAL,LSTCH,EVECTOR,EUVECTOR .GLOBAL CHRWRD .GLOBAL NONSPC ;MACRO TO FLOAT FF=0 ;FALG REGISTER DURING NUMBER CONVERSION ;FLAGS USED (RIGHT HALF) NOTNUM==1 ;NOT A NUMBER NFIRST==2 ;NOT FIRST CHARACTER BEING READ DECFRC==4 ;FORCE DECIMAL CONVERSION NEGF==10 ;NEGATE THIS THING NUMWIN==20 ;DIGIT(S) SEEN INSTRN==40 ;IN QUOTED CHARACTER STRING FLONUM==100 ;NUMBER IS FLOOATING POINT DOTSEN==200 ;. SEEN IN IMPUT STREAM EFLG==400 ;E SEEN FOR EXPONENT IFN FRMSIN,[ FRSDOT==1000 ;. CAME FIRST USEAGN==2000 ;SPECIAL DOT HACK ] ;TEMPORARY OFFSETS VCNT==0 ;NUMBER OF ELEMENTS IN CURRENT VECTOR ONUM==1 ;CURRENT NUMBER IN OCTAL DNUM==3 ;CURRENT NUMBER IN DECIMAL FNUM==5 ;CURRENTLY UNUSED CNUM==7 ;IN CURRENT RADIX NDIGS==11 ;NUMBER OF DIGITS ENUM==13 ;EXPONENT ; TEXT FILE LOADING PROGRAM MFUNCTION LOAD,SUBR ENTRY HLRZ A,AB ;GET NO. OF ARGS CAIE A,-4 ;IS IT 2 JRST TRY2 ;NO, TRY ANOTHER HLRZ A,2(AB) ;GET TYPE CAIE A,TOBLS ;IS IT OBLIST JRST WRONGT JRST CHECK1 TRY2: CAIE A,-2 ;IS ONE SUPPLIED JRST WNA" CHECK1: HLRZ A,(AB) ;GET TYPE CAIE A,TCHAN ;IS IT A CHANNEL JRST WRONGT LOAD1: HLRZ A,TB ;GET CURRENT TIME PUSH TP,$TTIME ;AND SAVE IT PUSH TP,A LOAD2: PUSH TP,(TB) ;USE TIME AS EOF ARG PUSH TP,1(TB) PUSH TP,(AB) ;USE SUPPLIED CHANNEL PUSH TP,1(AB) CAML AB,[-2,,0] ;CHECK FOR 2ND ARG JRST LOAD3 ;NONE PUSH TP,2(AB) ;PUSH ON 2ND ARG PUSH TP,3(AB) MCALL 3,READ JRST CHKRET ;CHECK FOR EOF RET LOAD3: MCALL 2,READ CHKRET: CAMN A,(TB) ;IS TYPE EOF HACK CAME B,1(TB) ;AND IS VALUE JRST EVALIT ;NO, GO EVAL RESULT PUSH TP,(AB) PUSH TP,1(AB) MCALL 1,FCLOSE MOVE A,$TCHSTR MOVE B,CHQUOTE DONE JRST FINIS EVALIT: PUSH TP,A PUSH TP,B MCALL 1,EVAL JRST LOAD2 ; OTHER FILE LOADING PROGRAM MFUNCTION FLOAD,SUBR ENTRY MOVEI C,1 ;INITIALIZE OPEN'S ARG COUNT PUSH TP,$TAB ;SLOT FOR SAVED AB PUSH TP,[0] ;EMPTY FOR NOW PUSH TP,$TCHSTR ;PUT IN FIRST ARG PUSH TP,CHQUOTE READ MOVE A,AB ;COPY OF ARGUMENT POINTER FARGS: JUMPGE A,CALOPN ;DONE? IF SO CALL OPEN HLRZ B,(A) ;NO, CHECK TYPE OF THIS ARG CAIN B,TOBLS ;OBLIST? JRST OBLSV ;YES, GO SAVE IT PUSH TP,(A) ;SAVE THESE ARGS PUSH TP,1(A) ADD A,[2,,2] ;BUMP A AOJA C,FARGS ;COUNT AND GO OBLSV: MOVEM A,1(TB) ;SAVE THE AB CALOPN: ACALL C,FOPEN ;OPEN THE FILE JUMPE B,FNFFL ;FILE MUST NO EXIST EXCH A,(TB) ;PLACE CHANNEL ON STACK EXCH B,1(TB) ;OBTAINING POSSIBLE OBLIST JUMPN B,2ARGS ;OBLIST SUOPPLIED? MCALL 1,LOAD ;NO, JUST CALL JRST FINIS 2ARGS: PUSH TP,(B) ;PUSH THE OBLIST PUSH TP,1(B) MCALL 2,LOAD JRST FINIS FNFFL: PUSH TP,$TATOM PUSH TP,MQUOTE FILE-NOT-FOUND JRST CALER1 MFUNCTION RREADC,SUBR,READCHR ENTRY PUSH P,[IREADC] ;WHERE TO GO AFTER BINDING JRST READ0 ;GO BIND VARIABLES MFUNCTION NXTRDC,SUBR,NEXTCHR ENTRY PUSH P,[INXTRD] JRST READ0 MFUNCTION READ,SUBR ENTRY PUSH P,[IREAD1] ;WHERE TO GO AFTER BINDING READ0: PUSH TP,$TTP ;SLOT FOR LAST THING READ (TYPE IS UNREADABLE) PUSH TP,[0] PUSH TP,$TFIX ;SLOT FOR RADIX PUSH TP,[0] PUSH TP,$TCHAN ;AND SLOT FOR CHANNEL PUSH TP,[0] JUMPGE AB,READ1 ;NO ARGS, NO BINDING MOVE B,AB ;GET A COPY OF THE ARG BLOCK MOVEI D,0 ;ACCESS ARG TABLE ARGLP: HLRZ C,(B) ;ISOLATE TYPE XCT ARGS(D) ;DO THE APROPRIATE COMPARE JRST WRONGT PUSH TP,[TATOM,,-1] ;PUSH THE ATOMS PUSH TP,@ARGS+1(D) PUSH TP,(B) ;PUSH ARGS PUSH TP,1(B) PUSH TP,[0] ;DUMMY PUSH TP,[0] ADDI D,2 ;BUMP ARG TBL POINTER ADD B,[2,,2] ;AND ARG POINTER JUMPL B,ARGLP ;MORE? PUSHJ P,SPECBIND ;NO, GO BIND ; ARGUMENTS ARE BOUND, NOW GET THE VALUES OF THINGS READ1: MOVE B,MQUOTE INCHAN,, ;GET INPUT CHANNEL MOVSI A,TATOM PUSHJ P,IDVAL ;NOW GOBBLE THE REAL CHANNEL CAME A,$TCHAN ;IS IT A CHANNEL JRST CHNLOS MOVEM B,5(TB) ;SAVE CHANNEL MOVEI B,DIRECT-1(B) ;POINT TO DIRECTION PUSHJ P,CHRWRD ;GOBBLE AND CHECK JRST WRNGDI CAME B,[ASCIZ /READ/] JRST WRNGDI MOVE B,5(TB) GETIO: MOVE A,IOINS(B) ;GOBBLE THE I/O INSTRUCTION JUMPE A,OPNFIL ;GO REALLY OPEN THE CROCK MOVE A,RADX(B) ;GET RADIX MOVEM A,3(TB) MOVEM B,5(TB) ;SAVE CHANNEL REREAD: MOVE D,LSTCH(B) ;ANY CHARS AROUND? CAIN D,233 ;FLUSH THE TERMINATOR HACK SETZM LSTCH(B) PUSHJ P,@(P) ;CALL INTERNAL READER JRST BADTRM ;LOST RFINIS: MOVE C,5(TB) ;GET CHANNEL MOVE D,LSTCH(C) ;GET LAST CHR CAIN D,233 ;SPECIAL ENDER? SETZM LSTCH(C) ;YES CLOBBER SUB P,[1,,1] ;POP OFF LOSER JRST FINIS BADTRM: CAIE B,3 ;READ 'FAILED' IS LOSER EOF JRST CHLSTC ;NO, MUST BE UNMATCHED PARENS PUSH TP,4(TB) ;CLOSE THE CHANNEL PUSH TP,5(TB) MCALL 1,FCLOSE MOVE B,MQUOTE EOF,, ;GET EOF MOVSI A,TATOM PUSHJ P,IDVAL ;GET LOCAL VALUE CAMN A,$TUNBOU ;UNBOUND IS ONLY LOSER JRST NEOF PUSH TP,A ;SETUP CALL TO EVAL PUSH TP,B MCALL 1,EVAL ;AND EVAL IT JRST RFINIS ; AND RETURN ;HERE TO ATTEMPT TO OPEN A CLOSED CHANNEL OPNFIL: PUSHJ P,OPNCHN ;GO DO THE OPEN JUMPE B,OPNERR ;LOSE IC B IS 0 JRST GETIO CHLSTC: MOVE B,5(TB) ;GET CHANNEL BACK JRST REREAD ;MAIN ENTRY TO READER IREAD: PUSHJ P,LSTCHR ;DON'T REREAD LAST CHARACTER IREAD1: INTGO PUSH TP,(TB) ;SAVE LAST FORM PUSH TP,1(TB) BDLP: PUSHJ P,NXTCH ;GOBBLE CHAR IN A AND TYPE IN D CAIG B,ENTYPE JUMPN B,@.+1(B) ;ERROR ON ZERO TYPE OR FUNNY TYPE JRST BADCHR DTBL: NUMLET ;HERE IF NUMBER OR LETTER NUMLET ;NUMBER NUMCOD==.-DTBL NUMLET ;+- NUMLET ;. DOTTYP==.-DTBL NUMLET ;E QUOTIT ;' - QUOTE THE FOLLOWING GOODIE QUOTYP==.-DTBL MACCAL ;% - INVOKE A READ TIME MACRO MACTYP==.-DTBL NUMLET ;\ - ESCAPE,BEGIN ATOM ESCTYP==.-DTBL ;TYPE OF ESCAPE CHARACTER QMARK ;? - SEVERAL POSSIBILITIES QMTYP==.-DTBL ALTACT ;_ - ARRTYP==.-DTBL GLOVAL ;, - GET GLOBAL VALUE GLMNT==.-DTBL NONSPC==.-DTBL ;NUMBER OF NON-SPECIAL CHARACTERS SPACE ;SPACING CHAR CR,LF,SP,TAB ETC. SPATYP==.-DTBL ;TYPE FOR SPACE CHARS ;THE FOLLOWING ENTRIES ARE VARIOUS PUNCTUATION CROCKS LPAREN ;( - BEGIN LIST LPRTYP==.-DTBL RPAREN ;) - END CURRENT LEVEL OF INPUT LBRACK ;[ -BEGIN ARRAY LBRTYP==.-DTBL RBRACK ;] - END OF ARRAY CSTRING ;" - CHARACTER STRING CSTYP==.-DTBL SPECTY ;# - SPECIAL TYPE TO BE READ OPNANG ;< - BEGIN ELEMENT CALL SLMNT==.-DTBL ;TYPE OF START OF SEGMENT CLSANG ;> - END ELEMENT CALL EOFCHR ;^C - END OF FILE COMNT ;; - BEGIN COMMENT NTYPES==.-DTBL ; EXTENDED TABLE FOR ! HACKS SEGDOT ;!. - CALL TO LVAL (SEG) DOTEXT==.-DTBL UVECIN ;![ - INPUT UNIFORM VECTOR ] LBREXT==.-DTBL QUOSEG ;!' - SEG CALL TO QUOTE QUOEXT==.-DTBL SINCHR ;!" - INPUT ONE CHARACTER CSEXT==.-DTBL SEGIN ;!< - SEG CALL SLMEXT==.-DTBL GLOSEG ;!, - SEG CALL TO GVAL GLMEXT==.-DTBL TERM ;!$ - (EXCAL-ALT MODE) PUT ALL CLOSES MANYT==.-DTBL GIVSEG ;! QMEXT==.-DTBL ALTSEG ;!_ - !@ BAREXT==.-DTBL ENTYPE==.-DTBL ;TRANSLATION TABLE FOR EXTENDED THINGIES EXTTBL: NUMCOD-1 ;!LETTER = LETTER NUMCOD ;!NUM = NUM NUMCOD+1 ;!+- = +- DOTEXT ;!. = !, PROBABLY DOTTYP+1 ;!E = E QUOEXT ;!' = ! MACTYP ;!% = % ESCTYP ;!\ = \ QMEXT ;!? = ! BAREXT ;!_ = ! GLMEXT ;!, = ! SPATYP ;!SPACE = SPACE LPRTYP ;!( = ( LBRTYP-1 ;!) = ) LBREXT ;![ = #UVECTOR[...] LBRTYP+1 ;!] = ] CSEXT ;!" = ONE CHAR NEXT CSTYP+1 ;!# = # SLMEXT ;!< = #SEGMENT(...) SLMNT+1 ;!> = > SLMNT+2 ;!^C = ^C SLMNT+3 ;!; = ; SPACE: PUSHJ P,LSTCHR ;DON'T REREAD SPACE JRST BDLP ;HERE ON NUMBER OR LETTER, START ATOM NUMLET: PUSHJ P,GOBBLE ;READ IN THE ATOM AND PUT PNTR ON ARG PDL JRST RET ;NO SKIP RETURN I.E. NON NIL ;HERE TO START BUILDING A CHARACTER STRING GOODIE CSTRING: PUSHJ P,GOBBL1 ;READ IN STRING JRST RET ;ARRIVE HERE TO INVOKE A READ TIME MACRO FUNCTION MACCAL: PUSHJ P,NXTCH1 ;READ ONE MORE CHARACTER CAIE B,MACTYP ;IS IT ANOTHER MACRO CHAR JRST MACAL1 ;NO, CALL MACRO AND USE VALUE PUSHJ P,LSTCHR ;DONT REREAD % PUSHJ P,MACAL1 ;OTHERWISE, USE SIDE EFFECCT, BUT NOT VALUE JFCL ;IGNORE LOSER JRST IREAD1 MACAL1: PUSHJ P,IREAD1 ;READ FUNCTION NAME PUSHJ P,ERRPAR ;BAD PARENS PUSH TP,A ;SAVE THE RESULT PUSH TP,B ;AND USE IT AS AN ARGUMENT MCALL 1,EVAL JRST RET ;CALL GOBBLE TO FIND THE TYPE AND THEN IREAD TO READ IT SPECTY: PUSHJ P,IREAD ;READ THE TYPES NAME (SHOULD BE AN ATOM) PUSHJ P,ERRPAR PUSH TP,A ;BEGIN SETTING UP CHTYPE CALL PUSH TP,B PUSHJ P,IREAD1 ;NOW READ STRUCTURE PUSHJ P,ERRPAR ;LOSSAGE EXCH A,-1(TP) ;USE AS FIRST ARG EXCH B,(TP) PUSH TP,A ;USE OTHER AS 2D ARG PUSH TP,B MCALL 2,CHTYPE ;ATTEMPT TO MUNG JRST RET ;THIS CODE CALLS IREAD RECURSIVELY TO READ THAT WHICH IS ;BETWEEN (), ARRIVED AT WHEN ( IS READ SEGIN: PUSH TP,$TSEG JRST OPNAN1 OPNANG: PUSH TP,$TFORM ;SAVE TYPE OPNAN1: PUSH P,[">] JRST LPARN1 LPAREN: PUSH P,[")] PUSH TP,$TLIST ;START BY ASSUMING NIL LPARN1: PUSH TP,[0] PUSHJ P,LSTCHR ;DON'T REREAD PARENS LLPLOP: PUSHJ P,IREAD1 ;READ IT JRST LDONE ;HIT TERMINATOR ;HERE WHEN MUST ADD CAR TO CURRENT WINNER GENCAR: PUSH TP,A ;SAVE TYPE OF VALUE PUSH TP,B ;AND VALUE MCALL 1,NCONS ;GOBBLE NIL LISTE MOVEM A,(TB) ;SAVE AWAY MOVEM B,1(TB) ;FOR COMMENT POP TP,C ;GET CDR JUMPN C,CDRIN ;IF STACKED GOODIE NOT NIL SKIP MOVE C,(TP) ;FIX UP LAT TYPE MOVEM C,(TB) PUSH TP,B ;AND USE AS TOTAL VALUE PUSH TP,A ;SAVE THIS AS FIRSST THING ON LIST JRST .+2 ;SKIP CDR SETTING CDRIN: HRRM B,(C) PUSH TP,B ;CLOBBER IN NEW PARTIAL GOODIE JRST LLPLOP ;AND CONTINUE ; HERE TO RAP UP LIST LDONE: CAME B,(P) ;CHECK VALIDITY OF CHARACTER PUSHJ P,MISMAT ;REPORT MISMATCH SUB P, [1,,1] POP TP,B ;GET VALUE OF PARTIAL RESULT POP TP,A ;AND TYPE OF SAME JUMPE B,RET ;VALUE IS NIL, DON'T POP AGAIN POP TP,B ;POP FIRST LIST ELEMENT POP TP,A ;AND TYPE JRST RET ;THIS CODE IS SIMILAR TO LIST GENERATING CODE BUT IS FOR VECTORS UVECIN: PUSH P,[EUVECTOR] ;PUSH NAME OF U VECT HACKER JRST LBRAK2 ;AND GO LBRACK: PUSH P,[EVECTOR] ;PUSH GEN VECTOR HACKER LBRAK2: PUSHJ P,LSTCHR ;FORCE READING NEW CHAR PUSH P,[0] ;INITIALIZE TO (WILL COUNT VECTOR ELEMENTS) LBRAK1: PUSHJ P,IREAD1 ;RECURSIVELY READ ELEMENTS OF ARRAY JRST LBDONE ;RAP UP ON TERMINATOR STAKIT: PUSH TP,A ;SAVE RESULT TYPE PUSH TP,B ;AND VALUE AOS VCNT(P) ;AND COUNT JRST LBRAK1 ; HERE TO RAP UP VECTOR LBDONE: CAIE B,"] ;FINISHED RETURN (WAS THE RIGHT STOP USED?) PUSHJ P,MISMAB ;WARN USER MOVE A,VCNT(P) ACALL A,@-1(P) ;MAKE THE VECTOR SUB P,[2,,2] JRST RET ; BUILD A SINGLE CHARACTER ITEM SINCHR: PUSHJ P,NXTC1 ;FORCE READ NEXT CAIN B,ESCTYP ;ESCAPE? PUSHJ P,NXTC1 ;RETRY LSHC A,29.-36. ;POSITION IN B MOVSI A,TCHRS JRST RETCL ; HERE ON RIGHT PAREN, BRACKET, ANGLE BRACKET OR CTL C CLSANG: ;CLOSE ANGLE BRACKETS RBRACK: ;COMMON RETURN FOR END OF ARRAY ALSO RPAREN: PUSHJ P,LSTCHR ;DON'T REREAD EOFCHR: MOVE B,A ;GETCHAR IN B MOVSI A,TCHRS ;AND TYPE IN A JRST RET1 ;AND LEAVE ; NORMAL RETURN FROM IREAD/IREAD1 RETCL: PUSHJ P,LSTCHR ;DONT REREAD RET: AOS (P) ;SKIP RET1: POP TP,1(TB) ;SAVE LAST READ CROCK POP TP,(TB) POPJ P, ;RANDOM MINI-SUBROUTINES USED BY THE READER ;READ A CHAR INTO A AND TYPE CODE INTO D NXTC1: MOVE B,5(TB) ;GET CHANNEL JRST NXTC2 NXTC: MOVE B,5(TB) ;GET CHANNEL SKIPN A,LSTCH(B) ;CHAR IN A IF REUSE NXTC2: XCT IOINS(B) ;GET CHARACTER FROM INPUT ANDI A,377 ;INCASE IT IS EOF MOVEM A,LSTCH(B) ;SAVE THE CHARACTER TRZE A,200 ;DONT SKIP IF SPECIAL JRST RETYPE ;GO HACK SPECIALLY GETCTP: PUSH P,A ;AND SAVE FROM DIVISION IDIVI A,CHRWD ;YIELDS WORD AND CHAR NUMBER LDB B,BYTPNT(B) ;GOBBLE TYPE CODE POP P,A POPJ P, ; NXTCH AND NXTCH1 ARE SAME AS NXTC AND NXTC1 EXCEPT THEY CHECK ! ; HACKS NXTCH1: PUSHJ P,NXTC1 ;READ CHAR JRST .+2 NXTCH: PUSHJ P,NXTC ;READ CHAR CAIE B,NTYPES+1 ;IF 1 > THAN MAX, MUST BE SPECIAL POPJ P, ;OTHERWISE JUST RETURN PUSHJ P,NXTC1 ;READ NEXT ONE CAIN B,1 ;LETTER? JRST UPLO ;YES, INVERT CASE RETYP1: CAIN B,SPATYP ;SPACER? JRST CHKALT ;YES, CHECK IT MOVE B,EXTTBL-1(B) ;USE TABLE FOR ALL OTHERS CRMLST: ADDI A,200 ;CLOBBER LASTCHR PUSH P,B MOVE B,5(TB) ;POINT TO CHANNEL MOVEM A,LSTCH(B) SUBI A,200 ;DECREASE CHAR POP P,B POPJ P, UPLO: ADDI A,40 ;CHANGE CASE OF LETTER IN A CAIL A,173 SUBI A,100 JRST CRMLST RETYPE: PUSHJ P,GETCTP ;GET TYPE OF CHAR JRST RETYP1 CHKALT: CAIN A,33 ;ALT? MOVEI B,MANYT JRST CRMLST TERM: MOVEI B,0 ;RETURN A 0 POPJ P, ;AND RETURN ;TABLE OF BYTE POINTERS FOR GETTING CHARS BYTPNT": 350700,,CHTBL(A) 260700,,CHTBL(A) 170700,,CHTBL(A) 100700,,CHTBL(A) 010700,,CHTBL(A) ;HERE ARE THE TABLES OF CHXRACTERS (NOTE EVERYTHING NOT SPECIFIED IS ;IN THE NUMBER LETTER CATAGORY) SETCHR 2,[0123456789] SETCHR 3,[+-] SETCHR 4,[.] SETCHR 5,[Ee] INCRCH 6,['%\?_,] ;NON-ATOM KILLING SPECIALS SETCOD 14,[15,12,11,14,40,33] ;ALL ARE TYPE 14 (SPACING - FF,TAB,SPACE,ALT-MODE) INCRCH 15,[()[]"#<>] ;GIVE THESE INCREASING CODES FROM 15 SETCOD 25,[3] ;^C - EOF CHARACTER INCRCH 26,[;!] ;COMMENT AND SPECIAL CHTBL: OUTTBL ;OUTPUT THE TABLE RIGHT HERE ; THIS CODE ASSOCIATES A COMMENT WITH THE LAST READ GOODIE COMNT: HLRZ A,(TB) ;CHECK THERE IS AN ITEM TO COMMENT CAIN A,TTP ;TYPE TP MEANS NONE THERE JRST NOCMNT PUSH TP,(TB) ;SAVE THEM PUSH TP,1(TB) MOVSI A,TTP ;RESET LAST GOODIE MOVEM A,(TB) SETZM 1(TB) PUSHJ P,IREAD ;CALL READER FLUSHING , PUSHJ P,ERRPAR PUSH TP,$TATOM PUSH TP,MQUOTE COMMENT PUSH TP,A ;PUSH THE COMMENT PUSH TP,B MCALL 3,PUT ;PUT THE COMMENT ON JRST BDLP ; THIS CODE FLUSHES WANDERING COMMENTS NOCMNT: PUSHJ P,IREAD PUSHJ P,ERRPAR JRST BDLP ;SUBROUTINE TO READ CHARS ONTO STACK GOBBL1: MOVEI FF,0 ;KILL ALL FLAGS PUSHJ P,LSTCHR ;DON'T REREAD " TROA FF,NOTNUM+INSTRN ;SURPRESS NUMBER CONVERSION GOBBLE: MOVEI FF,0 ;FLAGS CONCERRNING CURRENT GOODIE IN HERE MOVE A,TP ;GOBBLE CURRENT TP TO BE PUSHED MOVEI C,6 ;NOW PUSH 6 0'S ON TO STACK PUSH TP,$TFIX ;TYPE IS FIXED PUSH TP,FF ;AND VALUE IS 0 SOJG C,.-2 ;FOUR OF THEM PUSH TP,$TTP ;NOW SAVE OLD TP ADD A,[1,,1] ;MAKE IT LOOK LIKE A TB PUSH TP,A MOVEI D,0 ;ZERO OUT CHARACTER COUNT GOB1: MOVEI C,0 ;SET UP FIRST WORD OF CHARS PUSH P,[440700,,C] ;BYTE POINTER GOB2: PUSH P,FF ;SAVE FLAG REGISTER INTGO PUSHJ P,NXTCH ;READ A CHAACTER POP P,FF ;AND RESTORE FLAG REGISTER CAIN B,ESCTYP ;IS IT A CHARACTER TO BE ESCAPED JRST ESCHK ;GOBBLE THE ESCAPED CHARACTER TRNE FF,INSTRN ;ARE WE BUILDING A CHAR STRING JRST ADSTRN ;YES, GO READ IN CAILE B,NONSPC ;IS IT SPECIAL JRST DONEG ;YES, RAP THIS UP TRNE FF,NOTNUM ;IS NUMERIC STILL WINNING JRST SYMB2 ;NO, ONLY DO CHARACTER HACKING CAIL A,60 ;CHECK FOR DIGIT CAILE A,71 JRST SYMB1 ;NOT A DIGIT JRST CNV ;GO CONVERT TO NUMBER CNV: ;ARRIVE HERE IF STILL BUILDING A NUMBER CNV: MOVE B,(TP) ;GOBBLE POINTER TO TEMPS TRO FF,NUMWIN ;SAY DIGITSSEEN SUBI A,60 ;CONVERT TO A NUMBER TRNE FF,EFLG ;HAS E BEEN SEEN JRST ECNV ;YES, CONVERT EXPONENT TRNE FF,DOTSEN ;HAS A DOT BEEN SEEN JRST DECNV ;YES, THIS IS A FLOATING NUMBER JFCL 17,.+1 ;KILL ALL FLAGS MOVE E,CNUM(B) ;COMPUTE CURRENT RADIX IMUL E,3(TB) ADD E,A ;ADD IN CURRENT DIGIT JFCL 10,.+2 MOVEM E,CNUM(B) ;AND SAVE IT ;INSERT OCTAL AND CRADIX CROCK HERE IF NECESSSARY JRST DECNV1 ;CONVERT TO DECIMAL(FIXED) DECNV: TRO FF,FLONUM ;SET FLOATING FLAG DECNV1: JFCL 17,.+1 ;CLEAR ALL FLAGS MOVE E,DNUM(B) ;GET DECIMAL NUMBER IMULI E,10. JFCL 10,CNV2 ;JUMP IF OVERFLOW ADD E,A ;ADD IN DIGIT MOVEM E,DNUM(B) TRNE FF,FLONUM ;IS THIS FRACTION? SOS NDIGS(B) ;YES, DECREASE EXPONENT BY ONE CNV1: PUSHJ P,NXTCH ;RE-GOBBLE CHARACTER JRST SYMB2 ;ALSO DEPOSIT INTO SYMBOL BEING MADE îCNV2: ;OVERFLOW IN DECIMAL NUMBER TRNE FF,DOTSEN ;IS THIS FRACTION PART? JRST CNV1 ;YES,IGNORE DIGIT AOS NDIGS(B) ;NO, INCREASE IMPLICIT EXPONENT BY ONE TRO FF,FLONUM ;SET FLOATING FLAG BUT JRST CNV1 ;DO NOT FORCE DECIMAL(DECFRC) ECNV: ;CONVERT A DECIMAL EXPONENT HRRZ E,ENUM(B) ;GET EXPONENT IMULI E,10. ADD E,A ;ADD IN DIGIT TLNN E,777777 ;IF OVERFLOW INTO LEFT HALF HRRM E,ENUM(B) ;DO NOT STORE(CATCH ERROR LATER) JRST CNV1 JRST SYMB2 ;ALSO DEPOSIT INTO SYMBOL BEING MADE ;HERE TO PUT INTO IDENTIFIER BEING BUILT ESCHK: PUSHJ P,NXTC1 ;GOBBLE NEXT CHAR SYMB: MOVE B,(TP) ;GET BACK TEM POINTER TRNE FF,EFLG ;IF E FLAG SET HLRZ FF,ENUM(B) ;RESTORE SAVED FLAGS TRO FF,NOTNUM ;SET NOT NUMBER FLAG SYMB2: TRO FF,NFIRST ;NOT FIRST IN WORLD SYMB3: IDPB A,(P) ;INSERT IT PUSHJ P,LSTCHR ;READ NEW CHARACTER TRNN C,377 ;WORD FULL? JRST GOB2 ;NO, KEEP TRYING MOVEM C,(P) ;YES,STORE IT AOJA D,GOB1 ;COUNT WORD AND GO ;HERE TO CHECK FOR +,-,. IN NUMBER SYMB1: TRNE FF,NFIRST ;IS THIS THE FIRST CHARACTER JRST CHECK. ;NO, ONLY LOOK AT DOT CAIE A,"- ;IS IT MINUS JRST .+3 ;NO CHECK PLUS TRO FF,NEGF ;YES, NEGATE AT THE END JRST SYMB2 CAIN A,"+ ;IS IT + JRST SYMB2 ;ESSENTIALLY IGNORE IT ;COULD BE . CHECK.: PUSHJ P,LSTCHR ;FLUSH LAST CHARACTER MOVEI E,0 TRNN FF,DOTSEN+EFLG ;IF ONE ALREADY SEEN CAIE A,". JRST CHECKE ;GO LOOK FOR E IFN FRMSIN,[ TRNN FF,NFIRST ;IS IT THE FIRST JRST DOT1 ;YES, COULD MEAN EVALUATE A VARIABLE ] CHCK.1: TRO FF,DECFRC+DOTSEN ;FORCE DECIMAL IFN FRMSIN, TRNN FF,FRSDOT ;IF NOT FIRST ., PUT IN CHAR STRING JRST SYMB2 ;ENTER INTO SYMBOL IFN FRMSIN, JRST GOB2 ;IGNORE THE "." IFN FRMSIN,[ ;HERE TO SET UP FOR .FOO ..FOO OR. DOT1: PUSH P,FF ;SAVE FLAGS PUSHJ P,NXTCH1 ;GOBBLE A NEW CHARACTER POP P,FF ;RESTORE FLAGS TRO FF,FRSDOT ;SET FLAG IN CASE CAIN B,NUMCOD ;SKIP IF NOT NUMERIC JRST CHCK.1 ;NUMERIC, COULD BE FLONUM ; CODE TO HANDLE ALL IMPLICIT CALLS I.E. QUOTE, LVAL, GVAL MOVSI B,TFORM ;LVAL MOVE A,MQUOTE LVAL SUB P,[2,,2] ;POP OFF BYTE POINTER AND GOBBLE CALL POP TP,TP SUB TP,[1,,1] ;REMOVE TP JUNK JRST IMPCA1 GLOSEG: SKIPA B,$TSEG ;SEG CALL TO GVAL GLOVAL: MOVSI B,TFORM ;FORM CALL TO SAME MOVE A,MQUOTE GVAL JRST IMPCAL QUOSEG: SKIPA B,$TSEG ;SEG CALL TO QUOTE QUOTIT: MOVSI B,TFORM MOVE A,MQUOTE QUOTE JRST IMPCAL GIVSEG: MOVSI B,TSEG ;#SEGMENT MOVE A,MQUOTE GIVEN JRST IMPCAL ;(GIVEN...) GIVACT: MOVSI B,TFORM ;#FORM MOVE A,MQUOTE GIVEN JRST IMPCA1 ;(GIVEN...) ALTSEG: SKIPA B,$TSEG ;#SEGMENT ALTACT: MOVSI B,TFORM ;#FORM MOVE A,MQUOTE ALTER JRST IMPCAL ;(ALTER...) SEGDOT: MOVSI B,TSEG ;SEG CALL TO LVAL MOVE A,MQUOTE LVAL IMPCAL: PUSHJ P,LSTCHR ;FLUSH LAST CHAR EXCEPT IMPCA1: PUSH TP,$TATOM ;FOR .FOO FLAVOR PUSH TP,A ;PUSH ARGS PUSH P,B ;SAVE TYPE PUSHJ P,IREAD1 ;READ PUSHJ P,ERRPAR IMPCA2: PUSH TP,A ;PUSH RESULTS PUSH TP,B MCALL 2,LIST ;MAKE THE LIST POP P,A ;GET FINAL TYPE JRST RET ;AND RETURN ;? CAN MEAN ? OR OR #UNASSIGNED(...) QMARK: PUSHJ P,LSTCHR ;FLUSH "?" PUSHJ P,NXTCH ;GET NEXT CHARACTER CAIN B,LPRTYP ;"?("? JRST UNASIN ;YES- TYPE UNASSIGNED CAILE B,NONSPC ;NEXT CHARACTER BREAKS ATOMS? JRST ANY ;YES- HAVE STAND-ALONE "?" JRST GIVACT ;NO- NEXT THING IS ATOM UNASIN: PUSHJ P,IREAD1 ;READ NEXT THING PUSHJ P,ERRPAR PUSH TP,A PUSH TP,B PUSH TP,$TATOM PUSH TP,MQUOTE UNASSIGNED MCALL 2,CHTYPE ;CHANGE ITS TYPE TO UNASSIGNED JRST RET ANY: PUSH P,[ASCIZ /?/] ;? ALONE MUST BE ATOM PUSH P,[1] ;WITH ONE WORD PNAME MOVSI A,TATOM MOVE B,MQUOTE OBLIST, PUSHJ P,IDVAL ;PUT ON CURRENT OBLIST PUSHJ P,RLOOKU JRST RET ;HERE AFTER READING ATOM TO CALL VALUE .SET: SUB P,[1,,1] ;FLUSH GOBBLE CALL PUSH P,$TFORM ;GET WINNING TYPE .SET1: PUSH TP,$TATOM PUSH TP,MQUOTE LVAL JRST IMPCA2 ;GO CONS LIST ] ;HERE TO CHECK FOR "E" FLAVOR OF EXPONENT CHECKE: TRNN FF,EFLG ;HAS ONE BEEN SEEN CAIE A,"E ;IF NOT, IS THIS ONE JRST SYMB ;NO, ENTER AS SYMBOL KILL NUMERIC WIN TRNN FF,NUMWIN ;HAVE DIGITS BEEN SEEN? JRST SYMB ;NO, NOT A NUMBER MOVE B,(TP) ;GET POINTER TO TEMPS HRLM FF,ENUM(B) ;SAVE FLAGS HRRI FF,DECFRC+DOTSEN+EFLG ;SET NEW FLAGS JRST SYMB3 ;ENTER SYMBOL ;HERE ON READING CHARACTER STRING ADSTRN: CAIN B,MANYT ;TERMINATE? JRST DONEG ;YES CAIE A,"" ;QUOTE CHAR? JRST SYMB2 ;NO JUST INSERT IT ADSTN1: PUSHJ P,LSTCHR ;DON'T REREAD """ ;HERE TO FINISH THIS CROCK DONEG: TRNN FF,NUMWIN ;HAVE DIGITS BEEN SEEN? TRO FF,NOTNUM ;NO,SET NOT NUMBER FLAG POP P,A ;FLUSH POINT BYTER JUMPE C,.+3 ;LAST WORD USED? PUSH P,C ;YES, STORE IT AOS D ;AND BUMP COUNT PUSH P,D ;SAVE IT TRNN FF,NOTNUM ;NUMERIC? JRST NUMHAK ;IS NUMERIC, GO TO IT IFN FRMSIN,[ MOVE A,(TP) ;GET POINTER TO TEMPS MOVEM FF,NDIGS(A) ;USE TO HOLD FLAGS ] TRNE FF,INSTRN ;ARE WE BUILDING A STRING JRST MAKSTR ;YES, GO COMPLETE SAME MOVSI A,TATOM ;GET AATOM TYPE MOVE B,MQUOTE OBLIST, PUSHJ P,IDVAL ;GET VALUE PUSHJ P,RLOOKU IFN FRMSIN,[ MOVE C,(TP) ;SET TO REGOBBLE FLAGS MOVE FF,NDIGS(C) ] JRST FINID ;HERE TO RAP UP CHAR STRING ITEM MAKSTR: MOVE C,D ;SETUP TO CALL CHMAK PUSHJ P,CHMAK ;GO MAKE SAME JRST FINID NUMHAK: MOVE C,(TP) ;REGOBBLETEMP POINTER POP P,D ;POP OFF STACK TOP HRLI D,(D) ;TOO BOTH HALVES SUB P,D ;REMOVE CHAR STRING TRNE FF,FLONUM+EFLG ;IS IT A FLOATING POINT NUMBER JRST FLOATIT ;YES, GO MAKE IT WIN MOVE B,CNUM(C) TRNE FF,DECFRC MOVE B,DNUM(C) ;GRAB FIXED GOODIE FINID2: MOVSI A,TFIX ;SAY FIXED POINT FINID1: TRNE FF,NEGF ;NEGATE MOVNS B ;YES FINID: POP TP,TP ;RESTORE OLD TP SUB TP,[1,,1] ;FINISH HACK IFN FRMSIN,[ TRNE FF,FRSDOT ;DID . START IT JRST .SET ;YES, GO HACK ] POPJ P, ;AND RETURN FLOATIT:î JFCL 17,.+1 ;CLEAR ALL ARITHMETIC FLAGS TRNE FF,EFLG ;"E" SEEN? JRST EXPDO ;YES, DO EXPONENT MOVE D,NDIGS(C) ;GET IMPLICIT EXPONENT FLOATE: MOVE A,DNUM(C) ;GET DECIMAL NUMBER IDIVI A,400000 ;SPLIT FSC A,254 ;CONVERT MOST SIGNIFICANT FSC B,233 ; AND LEAST SIGNIFICANT FADR B,A ;COMBINE MOVM A,D ;GET MAGNITUDE OF EXPONENT CAILE A,37. ;HOW BIG? JRST FOOR ;TOO BIG-FLOATING OUT OF RANGE JUMPGE D,FLOAT1 ;JUMP IF EXPONENT POSITIVE FDVR B,TENTAB(A) ;DIVIDE BY TEN TO THE EXPONENT JRST SETFLO FLOAT1: FMPR B,TENTAB(A) ;SCALE UP SETFLO: JFCL 10,FOOR ;FLOATING OUT OF RANGE ON OVERFLOW MOVSI A,TFLOAT IFN FRMSIN, TRZ FF,FRSDOT ;FLOATING NUMBER NOT VALUE JRST FINID1 EXPDO: HRRZ D,ENUM(C) ;GET EXPONENT TRNE FF,NEGF ;IS EXPONENT NEGATIVE? MOVNS D ;YES ADD D,NDIGS(C) ;ADD IMPLICIT EXPONENT HLR FF,ENUM(C) ;RESTORE FLAGS JUMPL D,FLOATE ;FLOATING IF EXPONENT NEGATIVE CAIG D,10. ;OR IF EXPONENT TOO LARGE TRNE FF,FLONUM ;OR IF FLAG SET JRST FLOATE MOVE B,DNUM(C) ; IMUL B,ITENTB(D) JFCL 10,FLOATE ;IF OVERFLOW, MAKE FLOATING JRST FINID2 ;GO MAKE FIXED NUMBER ; HERE TO READ ONE CHARACTER FOR USER. INXTRD: SKIPA E,[JFCL] ;NULL CLEAR INS IREADC: MOVE E,[PUSHJ P,LSTCHR] ;AVOID RE-READ PUSHJ P,NXTC ;GOBBLE THE CHAR XCT E ;CLEAR LSTCHR IF NECESSARY CAIN A,3 ;IS IT EOF? JRST EOFCHR ;DO EOF RETURN MOVE B,A ;CHAR TO B LSH B,29. ;LEFT JUSTIFY MOVSI A,TCHRS ;AND TYPE JRST RET ; READER ERRORS COME HERE ERRPAR: PUSH TP,$TCHRS ;DO THE OFFENDER LSH B,29. ;POSITION IN WORD PUSH TP,B PUSH TP,$TCHRS PUSH TP,[40_29.] ;SPACE PUSH TP,$TATOM PUSH TP,MQUOTE WARNING-UNMATCHED MCALL 1,PRIN1 MCALL 1,PRINC MCALL 1,PRINC PUSHJ P,LSTCHR ;FLUSH THE CHARACTER SOS (P) ;SIMULATE JRST .-1 SOS (P) POPJ P, ;COMPLAIN ABOUT MISMATCHED CLOSINGS MISMAB: SKIPA A,["]] MISMAT: MOVE A,-1(P) ;GOBBLE THE DESIRED CHARACTER JUMPE B,CPOPJ ;IGNORE UNIVERSAL CLOSE LSH A,29. ;POSITION PUSH TP,$TCHRS PUSH TP,A PUSH TP,$TATOM PUSH TP,MQUOTE [ INSTEAD-OF ] PUSH TP,$TCHRS LSH B,29. PUSH TP,B MCALL 1,PRINC MCALL 1,PRINC MCALL 1,PRINC CPOPJ: POPJ P, ; HERE TO RESET A READ CHANNEL MFUNCTION RRRES,SUBR,RESET ENTRY 1 GETYP A,(AB) CAIE A,TCHAN JRST WRONGT MOVE C,1(AB) ;GET CHANNEL MOVEI B,DIRECT-1(C) ;POINT TO DIRECTION PUSHJ P,CHRWRD ;CONVER T TO A WORD JFCL CAME B,[ASCII /READ/] JRST WRNGDI MOVE B,1(AB) ;RESTORE CHANNEL SETZM LSTCH(B) PUSHJ P,RRESET" ;DO REAL RESET MOVE A,(AB) ;RETURN ARG JRST FINIS ; HERE ON BAD INPUT CHARACTER BADCHR: PUSH TP,$TATOM PUSH TP,MQUOTE BAD CHARACTER IGNORED MCALL 1,PRINT JRST IREAD ;EOF ERROR NEOF: PUSH TP,$TATOM ;GENERATE ERROR MESSAGE PUSH TP,MQUOTE EOF-REACHED JRST CALER1 ;LOSING CHANNEL FOR INPUT CHNLOS: PUSH TP,$TATOM PUSH TP,MQUOTE BAD-CHANNEL JRST CALER1 ;OPEN ERROR OPNERR: PUSH TP,$TATOM ;SETUP MESSAGE PUSH TP,MQUOTE OPEN-FAILED JRST CALER1 ;HERE FOR DIRECTION ERROR WRNGDI: PUSH TP,$TATOM ;SET UP ERROR PUSH TP,MQUOTE NOT-OPEN-FOR-READING JRST CALER1 ;WRONG ARG TYPE WRONGT: PUSH TP,$TATOM PUSH TP,MQUOTE WRONG-TYPE JRST CALER1 ;FLOATING POINT NUMBER TOO LARGE OR SMALL FOOR: PUSH TP,$TATOM PUSH TP,MQUOTE NUMBER-OUT-OF-RANGE JRST CALER1 NILSXP: 0,,0 LSTCHR: PUSH P,B MOVE B,5(TB) ;GET CHANNEL SETZM LSTCH(B) POP P,B POPJ P, ;TABLE OF NAMES OF ARGS AND ALLOWED TYPES ARGS: IRP A,,[[[CAIN C,TUNBOU],EOF],[[CAIE C,TCHAN],INCHAN],[[PUSHJ P,CHOBL],OBLIST]] IRP B,C,[A] B MQUOTE C .ISTOP TERMIN TERMIN CHOBL: CAIE C,TLIST ;A LIST OR AN OBLIST CAIN C,TOBLS AOS (P) POPJ P, END