.LIST TTM .TITLE FORTH PROGRAMMING SYSTEM .NLIST BEX,CND,ME,MD,SEQ .CSECT FORTH ;THIS VERSION IS FOR RT11 ONLY (TESTED ON V03B) ;WRITTEN BY H. WAYNE HAMMOND ;CALIFORNIA INSTITUTE OF TECHNOLOGY, 102-24, ;PASADENA, CA 91125 TEL 213-795-6811, EXT 1970 ;REVISED BY M. S. EWING, SEPT 26, 1978 - ELIM. TYP1 ; ADD AUTOMATIC 'FORTH LOAD' AT STARTUP 09/26/78 ; ADD .SFPA FOR FIS EXCEPTIONS 09/30/78 ; CHANGE <: TO >: 10/16/78 ; ELIMINATE RSX AND STANDALONE OPTIONS 10/17/78 ; (THESE MAY BE PROVIDED IN SEPARATE DECUS RELEASES) ; ADD .SCCA FOR CTRL-C INTERCEPT 10/18/78 ; MOVE KERNEL INTEGER DEFNS TO KERNEL 10/18/78 ; ADD ?^C TO CHECK FOR DOUBLE CTRL-C 10/18/78 ; DICTIONARY ENTRY FORMAT: ; --*---*---*---*---*---*---*---*---*---*---*---*---*---*---*---*-- ; ! LONG LINK FIELD ! ; ................................................................. ; ! CH #1 ! CH #2 ! CH #3 ! ! ; ................................................................. ; ! CH #4 ! COUNT - 4 ! P ! SHORT LINK FIELD ! ; ................................................................. ; THE LOW ORDER 4 BITS OF THE FIRST CHARACTER ARE USED TO MAKE A ; SIXTEEN-WAY THREAD DICTIONARY POINTER. THE 7-BIT ASCII CHARACTERS ; ARE COMPRESSED TO 6-BIT CHARACTERS. FOUR CHARACTERS ARE UNIQUE, ; AND THE CHARACTER COUNT IS TRUNCATED ABOVE 11. ; AUTOLD=1 ; AUTOMATIC 'FORTH LOAD' AT STARTUP ;LPDEV= 0 ; A LINE PRINTER IS AVAILABLE FOR RT11 FPNC= 1 ; ASSEMBLE FLOATING NUMBER CONVERTER ;EIS= 1 ; MACHINE HAS EIS ;EAE= 0 ; MACHINE HAS EAE LDBLK= 1 ; LOAD BLOCK: EIS=0, UNIVERSAL=1, EAE=2 SCCA= 1 ; CTRL-C INTERCEPT .SBTTL SYSTEM DEFINITIONS JSW= 44 ; JOB STATUS WORD USRSWP= 46 ; USR LOAD ADDRESS RMON= 54 ; BEGINNING OF RT11 RESIDENT MONITOR NMACRO= 0 ; NUMBER OF DEFINED MACROS T= %1 ; TOP ENTRY OF STACK FP= %4 ; PUSH DOWN STACK POINTER ; "FP" FOR RSX MACRO COMPATIBILITY IC= %5 ; "FORTH" INSTRUCTION COUNTER RP= %6 ; RETURN STACK POINTER(HARDWARE STACK) CR= 15 LF= 12 LWD= 2000 ; BLOCK LENGTH .IFDF EAE MQ= 177304 ; DEFINE EAE REGISTER AC= 177302 .ENDC MSGMAX= 120 ; I/O MESSAGE LENGTH MAXWRD= 100 BLK= 40 .SBTTL MACRO DEFINITIONS .MCALL .PRINT,.EXIT,.CLOSE,.READW,.WRITW,.WAIT .MCALL .RCTRLO,.TTYIN,.TTYOUT,.FETCH,.LOOKUP .MCALL .SRESET,.SETTOP,.TRPSET,.DSTATUS,.MTPS .MCALL .LOCK,.UNLOCK,..V2..,.ENTER,.PROTECT .MCALL .SFPA,.REGDEF,.SCCA ..V2.. .REGDEF .MACRO .CODE .L,.CNAME,.LNAME,.P L=.L-4 .IIF LT L-1 L=0 .IIF GT L-7 L=7 L=L*1000 .IF LT NMACRO-1 .WORD 0 H=0 .IRPC X,<1234567890123456> .LINK \H H=H+1 .ENDM .ENDC NMACRO=NMACRO+1 M=0 .IRPC X,^\.CNAME\ M=M+1 Y=''X ; Y=Y-40 .IF EQ M-1 Z1=Y/20 H=Y-<*20> .LINK \H .ENDC .IIF EQ M-2 Z1=Z1*100+Y .IIF EQ M-3 Z1=Z1*100+Y .IF EQ M-4 Z1=Z1*4+ Z2=*20>>*10000+L .ENDC .ENDR .IF NB .P PP=.P*400 .IFF PP=0 .ENDC Z2=Z2+LK+PP .WORD Z1 .WORD Z2 .ANON .LNAME .ENDM .MACRO .LINK N .IF GT NMACRO-1 LK=.-LKO'N/2 .IF GT LK-377 .WORD LK+1 LK=0 .ENDC .ENDC LKO'N=. LKN'N=. .ENDM .MACRO .ANON .LNAME .IF NB .LNAME .GLOBL .LNAME .LNAME: .ENDC .ENDM .MACRO .COLON .L,.CNAME,.LNAME,.P .CODE .L,^\.CNAME\,.LNAME,.P .WORD 4537 .ENDM .MACRO .CONS .L,.CNAME,.VALUE .COLON .L,^\.CNAME\ .WORD CON,.VALUE .ENDM .MACRO .NEXT JMP @(IC)+ .ENDM .SBTTL COMMON STORAGE RP00: ; HARDWARE RETURN STACK BUFF1: .BLKB LWD ; RESERVE BLOCK BUFFERS BUFF2: .BLKB LWD MSG0: .BLKB MSGMAX+4 ; RESERVE MESSAGE BUFFER OBJECT= . ; START OF OBJECT CODE MSG: MSG0 HEAD: LKN0,LKN1,LKN2,LKN3,LKN4,LKN5 LKN6,LKN7,LKN10,LKN11,LKN12 LKN13,LKN14,LKN15,LKN16,LKN17 BASE0: 10. ; CURRENT RADIX SP0: .BLKW 1 ; PARAMETER STACK PTR RP0: RP00 ; RETURN STACK POINTER LAST: LAST0 ; => TO FIRST INSTRUCTION OF LAST ENTRY DP: DP0 ; DICTIONARY POINTER DELIM: BLK ; CURRENT WORD DELIMITER PREV: BUFF1,-1,0 ; BUF PTR, BLK #, UPDATE FLG ALT: BUFF2,-1,0 STATE: 0 ; COMPILE/EXECUTE SCALE: 0 ; # OF DIGITS RT OF DECIMAL POINT PRECIS: 0 ; NUMERIC PRECISION FLAG 0 = SP >0 = DP SIGN: 0 .IFDF FPNC ESIGN= SIGN+1 ; EXPONENT SIGN BEXP: 0 ; BINARY EXPONENT EEXP: 0 ; DECIMAL EXPONENT .ENDC EMPTY: 1 ; 1 => TEXT BUFFER EMPTY ; 0 => TEXT BUFFER CONTAINS INPUT ; 2=> TEXT BUFFER EMPTY, TYPE # IN: 0 ; INPUT BUFFER OFFSET POINTER SCR: -1 ; SOURCE BLOCK # -1 = TTY >-1 = BLOCK OUT: MSG0 ; OUTPUT MESSAGE POINTER MSGTOP: MSG0+MSGMAX ; TOP OF I/O BUFFER WHAT: .BYTE 1,'? ; FORTH RESPONSES MBLK: .BYTE 1,BLK .EVEN FIRSTF: .WORD 1 ; FIRST TIME FLAG (CF ABORT0) .IFDF SCCA SCCAF: .WORD 1 ; DOUBLE CTRL-C FLAG .ENDC .SBTTL RT11 FILE SPECIFICATIONS CHANNL: FNAME ; CHANNEL 0 ALWAYS OPEN TRPA: .BYTE 0,3 TRAPS FNAME: .RAD50 /DK FORSYSDAT/ ; RT11 SYSTEM FILE NAME! .IF DF LPDEV LPNAME: .RAD50 /LP FORSYSLST/ .ENDC OPNERR: .ASCIZ /?OPEN ERR?/<12><15> .EVEN AREA: LOKBLK: .BLKW 3 NTRBLK: DSTATA: .BLKW 4 .IFDF LPDEV PTF: .WORD 0 .ENDC .SBTTL ABORT AND TRAP HANDLERS ABORT0: MOV RP0,RP ; RETURN STACK POINTER MOV DP,T ; PICK UP DP MOV #BLK,DELIM ; " " STD DELIMITER MOV #2,EMPTY ; SET INPUT EMPTY MOV SP0,FP ; INIT PARM STACK MOV #-1,SCR ; SYSTEM BLOCK NUMBER CLR STATE .MTPS #0 ; RUN AT PRIORITY 0 .IFDF SCCA CLR SCCAF ; CLEAR DOUBLE CTRL-C FLAG .ENDC .IFDF AUTOLD TST FIRSTF ; FIRST TIME FLAG BEQ NFST CLR FIRSTF MOV #ABORT3,IC ; INITIAL CODE BR FFST .ENDC NFST: MOV #ABORT2,IC ; INITIALIZE IC FFST: JMP PUSH1 ; AND AWAY WE GO .IFDF AUTOLD ABORT3: .WORD COUNT,TYPE ; DO THIS ON FIRST PASS .WORD CRSND ; SEND CRLF IMMEDIATELY .WORD LIT,LDBLK,LOAD ; FORTH LOAD .WORD QUERY .ENDC ABORT2: .WORD COUNT,TYPE,LIT .WORD WHAT .WORD COUNT,TYPE,QUERY TRAPS: .TRPSET #TRPA,#TRAPS ; RESET TRAPS 4,10 .SFPA #TRPA,#TRAPS ; SAME FOR FIS ********* ;**************************************************** .SBTTL OBJECT DICTIONARY HEAD ;**************************************************** .CODE 4,CRLF,CRLF,1 ; ***** "CRLF" MOV #2,EMPTY .NEXT .CODE 3,,CTRLC2 ; ***** ?^C .IFDF SCCA TST SCCAF ; CHECK DOUBLE CTRL-C FLAG BEQ 1$ JMP ABORT0 ; YES, ABORT .ENDC 1$: .NEXT ; IF NO .SCCA, THIS IS A NO-OP .CONS 7,CHAN,CHANNL ; ***** CHANNEL .CONS 6,SYST,FNAME ; ***** SYSTEM .IFDF LPDEV .CODE 7,PRIN ; ***** PRINTER .PROTE #AREA,#200 ; PROTECT THE PRINTER VECTOR BCS ABORT0 ; IF CS ERROR MOV #1,PTF ; SET PRINTER/TERMINAL FLAG .NEXT .CODE 10,TERM ; ***** TERMINAL TST PTF ; CHECK IF PRINTER IN USE BEQ 10$ ; IF EQ NO MOV RMON,R0 ; GET BEGINNING OF RT11 BICB #300,336(R0) ; REMOVE PROTECTION BITS 10$: CLR PTF ; RESET TO TERMINAL .NEXT .ENDC .SBTTL RT11 TELETYPE INPUT RECEIV: ; ***** RECEIV MOV MSG,R1 ; INITIALIZE POINTERS MOV R1,IN .RCTRLO .TTYOUT #'# BIC #010000,@#JSW ; NORMAL I/O REC1: .TTYIN ; WAIT FOR A CHARACTER .IFDF SCCA CMP #3,R0 ; CONTROL-C? BNE 1$ JMP ABORT0 ; YES, ABORT 1$: .ENDC CMP #BLK,R0 ; PRINTING CHARACTER BHI REC2 ; NO.. MOVB R0,(R1)+ ; PUT IN BUFFER BR REC1 REC2: CMP #CR,R0 ; CARRIAGE RETURN? BNE REC3 ; NO.. MOVB #BLK,(R1)+ ; INSERT A BLANK MOVB R0,(R1)+ ; THEN THE CR BR REC1 ; WAIT FOR THE LF REC3: CMP #LF,R0 ; LINE FEED? BNE REC1 ; IGNORE ALL OTHERS CMPB -1(R1),#CR ; LAST CHARACTER A CR? BEQ REC4 ; YES.. MOVB #BLK,(R1)+ ; FORCE A CRLF PAIR MOVB #CR,(R1)+ REC4: MOVB R0,(R1)+ MOVB #BLK,@R1 ; APPEND A BLANK RTS PC .SBTTL RT11 TELETYPE OUTPUT .IFDF LPDEV .IFTF SEND: ; ***** SEND CLRB @OUT ; FORCE .IFT TST PTF ; CHECK THE OUTPUT DEVICE BNE 10$ ; IF NE USE THE PRINTER .IFTF .PRINT MSG .IFT BR 20$ 10$: MOV OUT,R1 ; GET MESSAGE LENGTH MOVB #LF,(R1)+ CLRB (R1)+ SUB MSG,R1 ASR R1 .WRITW #AREA,#11,MSG,R1,#200 20$: .IFTF MOV MSG,OUT RTS PC .ENDC .PRINT MSG MOV MSG,OUT ; RESET OUTPUT POINTER RTS PC .SBTTL ARITHMETIC DEFINITIONS .CODE 4,DROP,POP1 ; ***** DROP,POP1 TST (FP)+ ; POP 1 ELEMENT FPCHK: CMP FP,SP0 ; HAS UNDERFLOW OCCURED? BHI FPERR ; YES..SO SORRY! .NEXT .CODE 4,SWAP ; ***** SWAP MOV 2(FP),T MOV @FP,2(FP) PUT1: MOV T,@FP .NEXT .CODE 1,<+ > ; ***** + ADD (FP)+,@FP ; ADD TOP TWO ELEMENTS .NEXT .CODE 3, ; ***** DUP MOV @FP,T PUSH1: TST -(FP) ; CREATE NEXT STACK CELL CMP FP,DP ; STACK OVERFLOW? BHI PUT1 ; OK .. FPERR: JMP ABORT0 ; KILL EVERYTHING .SBTTL INPUT STRING PARSER .COLON 4,WORD,WORD ; ***** WORD .WORD SCR1,BLOCK.,WORD1,SEMI .ANON SCR1 ; ***** SCR1 MOV SCR,T ; INPUT FROM VIRTUAL CORE? BGE PUSH1 ; YES..MUST DO BLOCK I/O TST (IC)+ ; NO..SKIP BLOCK I/O CLR T ; FIX FOR TELETYPE INPUT BR PUSH1 .ANON WORD1 ; ***** WORD1 MOV DP,R3 ; THE OUTPUT ADRS=NEXT DICT ENTRY MOV IN,R2 ; GET INPUT BUFFER POINTER ADD @FP,R2 ; ZERO IF BLOCK 0; BUFR ADRS OTHERWISE CLRB (R3)+ ; (WORKS) ON 1ST WORD ONLY!) ; LEAVE ROOM FOR BYTE COUNT CLR R0 ; CLEAR CHARACTER COUNT CMPB (R2)+,DELIM ; WORD END? ; PITCH EXTRA DELIMITERS BEQ .-4 WORD11: MOVB -1(R2),(R3)+ ; PUT NEXT CHAR IN STRING INC R0 ; KEEP TRACK OF STRING LENGTH CMPB (R2)+,DELIM ; NEXT CHARACTER A DELIMITER? BNE WORD11 ; IF SO..KEEP GOING MOVB R0,@DP ; SET THE STRING LENGTH SUB (FP)+,R2 ; RESTORE THE DAMAGE DONE ABOVE AND MOV R2,IN ; SAVE THE INPUT POINTER MOVB #' ,DELIM ; RESET DELIMITER TO A BLANK SUB #4,R0 ; APPEND AT LEAST ONE BLANK WORD12: MOVB #' ,(R3)+ ; AND POSSIBLY THREE TO THE INC R0 ; STRING JUST PARSED BLE WORD12 .NEXT .SBTTL DICTIONARY SEARCH .CODE 4,FIND,FIND ; ***** FIND JSR PC,CMPRES ; COMPACT ENTRY STRING MOV @(FP)+,R2 ; USE HEAD POINTER 1$: CMP R0,@R2 ; MATCH WITH 2 2/3 CHARACTERS? BNE 2$ ; NO.. MOV 2(R2),R3 ; HOW ABOUT REST OF ENTRY BIC #777,R3 CMP R1,R3 BNE 2$ ; NO.. ADD #4,R2 ; SKIP ENTRY .NEXT 2$: MOVB 2(R2),R3 ; PICK UP THE LINK BIC #177400,R3 BNE 3$ MOV -2(R2),R3 ; TRY THE LONG LINK 3$: ASL R3 BEQ 4$ ; 0=> END OF DICTIONARY SUB R3,R2 ; POINT TO PRECEDING ENTRY BR 1$ 4$: CMP (IC)+,(IC)+ ; SEARCH FAILED .NEXT .SBTTL TEXT INTERPRETER .ANON EXECUT ; ***** EXECUT MOVB -1(R2),R0 ; GET THE PRECEDENCE BIC #177776,R0 CMP R0,STATE ; COMPILE/EXECUTE BHIS DO1 ; EXECUTE THIS WORD, OTHERWISE COMPL: MOV R2,@DP ; CODE ADRS IS COMPILED INTO ; PARAMETER LIST OF THE WORD ; BEING DEFINED ADD #2,DP .NEXT ; 'IC' IS THE FORTH INSTRUCTION COUNTER ; 'NEXT' EXECUTES THE CODE POINTED ; TO INDIRECTLY BY IC. DO1: JMP @R2 ; EXECUTE CODE ADDR NOW!!!!!!! ; INTERPRETER LOOP FOR DICTIONARY REFERENCES BY NAME GO: .IFDF SCCA .WORD CTRLC2 ; CHECK FOR 2 CTRL-C .ENDC .WORD WORD,FIND,EXECUT,QUERY .WORD NUMBER,LITERAL,QUERY .WORD QUESTN .SBTTL ENTRY DEFINING WORDS .COLON 4,CODE,CODE ; ***** CODE .WORD WORD,ENTRY,SEMI ; 'CODE' CREATES A DICTIONARY ENTRY ; FOR MACRO11 TYPE WORDS .COLON 1,<: >,COLON ; ***** COLON .WORD CODE,COLONS,SEMI; 'COLON' CREATES A DICTIONARY ENTRY ; FOLLOWED BY A JSR IC,@# TO ; PROCESS PARAMETER LIST AS ADDRESSES .CODE 2,^\>: \ ; ***** >: MOV LAST,R3 ; SWITCH TO COMPILE STATE .ANON COLONS ; ***** COLONS CMP -(R3),-(R3) ; POINT TO BEGINNING OF ENTRY MOV @R3,COLON0 ; THIS PREVENTS RECURSIVE DEFINIFIONS CLR (R3)+ MOV @R3,COLON0+2 MOVB #16,1(R3) MOV #1,STATE ; SET COMPILE BIT MOV #4537,R2 ; AND COMPILE THE JSR BR COMPL COLON0: .BLKW 2 .COLON 5,ENTE,ENTER ; ***** ENTER .WORD COLON,SEMIC,SEMI; 'ENTER' CREATES A DICTIONARY ENTRY ; WITH A JSR IC,@# AND AN EMPTY WORD ; FOLLOWING. 'ENTER' IS USED FOR ; CREATING NEW CLASSES OF WORDS. .CODE 1,<; >,,1 ; ***** ; MOV #SEMI,R2 ; ';' TERMINATES ALL : COLON DEFINITIONS SEMIC: MOV LAST,R1 ; TURN OFF THE COMPILE TO EXECUTE CMP -(R1),-(R1) MOV COLON0,(R1)+ ; RESET THE WORD : SET TO ZERO BIC #7000,@R1 BIS COLON0+2,@R1 CLR STATE ; => EXECUTE BR COMPL ; INSERT THE ADDRESS .CODE 5,<;COD>,,1 ; ***** ;CODE MOV #SCODE,R2 ; ;CODE TERMINATES A : DEFINATION ; THAT DEFINES A NEW CLASS OF WORDS ; I.E. INTEGER, ORCON, ETC. BR SEMIC ; END : PORTION OF DEFINITION .ANON SCODE ; ***** SCODE MOV LAST,R0 ; THIS ALTERS THE FIRST CODE ADDRS MOV IC,2(R0) .ANON SEMI ; ***** SEMI MOV (RP)+,IC ; RP POINTS TO LAST USED WORD .NEXT .CODE 1,<, >,COMMA ; ***** , MOV (FP)+,R2 ; PUT PARAMETER INTO DICTIONARY BR COMPL .CODE 2,^\:> \,,1 ; ***** :> MOV #RTSIC,R2 ; SWITCH TO EXECUTE STATE BR SEMIC RTSIC: RTS IC .IFNDF FPNC .SBTTL NUMBER CONVERTER .CODE 6,NUMB,NUMBER ; ***** NUMBER MOV IC,-(RP) ; SAVE INSTRUCTION COUNTER MOV DP,R5 ; GET DICTIONARY POINTER INC R5 ; SKIP CHARACTER COUNT CLR -(FP) ; ZERO ACCUMULATOR CLR -(FP) CLR PRECIS ; AND PRECISION FLAG MOV #-100,SCALE ; LOAD # FRACTIONAL DIGITS MOV BASE0,R2 ; GET CONVERSION RADIX CLR -(RP) ; CLEAR TEMPORARY STORAGE MOVB (R5)+,@RP ; GET FIRST CHARACTER MOV @RP,SIGN ; KEEP COPY FOR SIGN CMP #'-,@RP ; IS IT A "-" BEQ NATURL+4 ; YES.. CMP #'+,@RP ; OR A "+" BNE NATURL+6 ; NO.. NATURL: MOV BASE0,R2 ; GET THE RADIX MOVB (R5)+,@RP ; GET NEXT DIGIT SUB #'0,@RP ; ASCII -> BCD BMI NONDIG ; IT'S NOT A NUMBER CMP R2,@RP BLOS NONDIG ; SO TRY SOMETHING ELSE INC SCALE ; COUNT THIS DIGIT .IFDF EIS MOV (FP)+,R3 ; GET ACC(H) MUL R2,R3 ; * RADIX MOV @FP,R0 ; AND ACC(L) MUL R2,R0 ; * RADIX BPL .+4 ADD R2,R0 ; FIX FOR LOGICAL * ADD R3,R0 ADD @RP,R1 ; ADD NEXT DIGIT ADC R0 MOV R1,@FP ; UPDATE ACCUMULATOR MOV R0,-(FP) .ENDC .IFDF EAE MOV #MQ,R3 ; POINT TO MQ IN EAE MOV (FP)+,(R3)+ ; GET ACC(H) MOV R2,@R3 ; * RADIX MOV -(R3),R0 MOV @FP,(R3)+ ; GET ACC(L) BPL .+4 ; FIX LOGICAL * ADD R2,R0 MOV R2,@R3 ; * RADIX MOV -(R3),R1 ADD -(R3),R0 ADD @RP,R1 ; ADD DIGIT ADC R0 MOV R1,@FP ; UPDATE ACCUMULATOR MOV R0,-(FP) .ENDC .IFNDF EIS&EAE DEC R2 MOV 2(FP),R1 ; COPY ACCUMULATOR MOV @FP,R0 MPYLP: ADD R0,@FP ; DO RADIX ADDITIONS ADD R1,2(FP) ADC @FP DEC R2 ; ARE WE DONE? BGT MPYLP ; NO.. ADD @RP,2(FP) ; ADD DIGIT ADC @FP .ENDC BR NATURL ; DO NEXT DIGIT NONDIG: ADD #'0,@RP ; BCD => ASCII CMP #':,@RP ; SEXIGESIMAL? BNE NPOINT ; NO.. ADD #4,PRECIS MOV #6,R2 ; SET RADIX = 6 BR NATURL+4 ; GET ANOTHER DIGIT NPOINT: CMP #'.,@RP ; DECIMAL POINT ? BNE NFINIS ; NO.. BIT #1,PRECIS ; MORE THAN ONE? BNE NFINIS ; YES.. INC PRECIS CLR SCALE BR NATURL NFINIS: CMP #'-,SIGN ; NEGATE THE NUMBER? BNE NDELIM ; NO.. NEG @FP NEG 2(FP) SBC @FP NDELIM: CMP (RP)+,DELIM ; VALID END? BEQ .+6 ; YES.. ADD #4,@RP ; IC => "QUESTN" IN GO LOOP MOV (RP)+,IC .NEXT .CODE 7,LITE,LITERAL ; ***** LITERAL TST PRECIS ; SINGLE/DOUBLE? BNE .+4 TST (FP)+ ; GET RID OF ACC(H) MODE: TSTB STATE ; COMPILE/EXECUTE? BEQ EXEC1 ; EXIT ON EXECUTE MOV DP,R3 ; GET DICTIONARY POINTER TST PRECIS ; COMPILE SINGLE/DOUBLE BEQ CMPL1 ; SKIP FOR SINGLE MOV #LIT.,(R3)+ MOV (FP)+,(R3)+ BR CMPL1A CMPL1: MOV #LIT,(R3)+ CMPL1A: MOV (FP)+,(R3)+ MOV R3,DP EXEC1: .NEXT .ANON LIT ; ***** LIT MOV (IC)+,T ; LOAD SINGLE PARAMETER JMP PUSH1 .ANON LIT. ; ***** LIT. MOV (IC)+,T ; LOAD DOUBLE PARAMETER MOV (IC)+,-(FP) JMP PUSH1 .IFF .SBTTL FP NUMBER CONVERTER .CODE 6,NUMB,NUMBER ; ***** NUMBER MOV IC,-(RP) ; SAVE INSTR. COUNTER MOV DP,R5 ; GET DICTIONARY POINTER INC R5 ; SKIP STRING COUNT MOV #-1,PRECIS ; GET PRECISION FLAG MOV #100,SCALE ; INITIALIZE SCALE CLR -(FP) ; CLEAR FOUR WORD ACCUMULATOR CLR -(FP) CLR -(FP) CLR -(FP) CLR -(RP) ; CHAR. STORAGE MOV BASE0,R2 ; GET RADIX MOVB @R5,@RP ; GET FIRST CHAR. MOVB (R5)+,SIGN ; SAVE SIGN CMPB #'-,@RP ; IS IT "-" ? BEQ 10$ ; YES CMPB #'+,@RP ; IS IT "+" ? BNE 15$ ; NO 10$: MOVB (R5)+,@RP ; GET NEXT DIGIT 15$: SUB #'0,@RP ; ASCII TO BCD BMI 50$ ; NOT DIGIT CMPB R2,@RP ; VALID DIGIT ? BLOS 50$ ; NO MOV FP,R3 ; GET POINTER ADD #10,R3 ; BUMP IT .IFDF EIS MOV @RP,R0 ; GET DIGIT 20$: MOV -(R3),R1 ; GET ARG. MOV R0,@R3 ; PUT IN PREVIOUS VALUE MOV R1,R0 BEQ 40$ ; SKIP IF ZERO MUL R2,R0 ; MULT. BY RADIX BPL 30$ ADD R2,R0 ; LOGICAL FIX 30$: ADD R1,@R3 ; ADD IN LOW ORDER RESULT ADC R0 40$: CMP R3,FP ; ARE WE DONE ? BHI 20$ .ENDC .IFDF EAE MOV #AC,R0 ; POINT TO EAE REGISTERS MOV @RP,@R0 ; USE DIGIT 20$: MOV -(R3),R1 ; GET ARGUMENT MOV (R0)+,@R3 ; PUT IN PREVIOUS VALUE MOV R1,@R0 MOV R2,2(R0) ; MULT. BY RADIX TST -2(R0) BPL 30$ ADD R2,-2(R0) ; FIX LOGICAL MULT. 30$: ADD @R0,@R3 ; ADD IN LOW RESULT ADC -(R0) 40$: CMP R3,FP ; ARE WE DONE? BHI 20$ .ENDC .IFNDF EAE&EIS MOV R5,-(RP) ; SAVE STRING POINTER DEC R2 ; CORRECT RADIX MOV R2,-(RP) ; AND KEEP IT MOV -(R3),R5 ; GET PREVIOUS VALUE MOV -(R3),R2 MOV -(R3),R1 MOV -(R3),R0 20$: ADD #10,R3 ; RESET POINTER ADD R5,-(R3) ; DO THE MULTIPLY ADC R2 ADC R1 ADC R0 ADD R2,-(R3) ADC R1 ADC R0 ADD R1,-(R3) ADC R0 ADD R0,-(R3) DEC @RP ; ARE WE DONE? BGT 20$ TST (RP)+ ; POP RADIX MOV (RP)+,R5 ; RESTORE THE POINTER ADD @RP,6(FP) ; ADD IN CURRENT DIGIT MOV BASE0,R2 ; RESTORE THE RADIX .ENDC DEC SCALE ; BUMP SCALE BR 10$ ; DONE 50$: ADD #'0,@RP ; BCD TO ASCII CMPB #',,@RP ; ',' => DP FIXED POINT BNE 60$ ; NO INC PRECIS ; RESET PRECISION BLE 65$ 55$: JMP NUMERR ; TOO MANY DECIMAL POINTS 60$: CMPB #'.,@RP ; '.' => SP FLOATING POINT BNE NUMFP ; LOOK FURTHER TST PRECIS ; CHECK FOR MULTIPLE .'S BGE 55$ ; IF NE TOO MANY MOV #2,PRECIS ; SET THE PRECISION 65$: CLR SCALE ; RESET FRACTIONAL DIGITS BR 10$ NUMFP: CMPB #'E,@RP ; SINGLE FLOATING ? BNE 10$ ; NO MOV #2,PRECIS ; YES. RESET PREC. BR 30$ 10$: CMPB #'D,@RP ; DOUBLE FLOATING ? BNE 20$ MOV #3,PRECIS ; YES. RESET PRECISION 20$: CMP PRECIS,#2 ; FLOATING POINT NUMBER? BLT NUMSGN ; IF LT NO 30$: MOV #270,BEXP ; INCLUDE OFFSET IN EXP JSR PC,BNORM ; NORMALIZE MOV SCALE,EEXP ; GET SCALE BMI . + 6 CLR EEXP CLR R1 CMP DELIM,@RP ; NEED AN EXPONENT? BEQ 40$ ; IF EQ NO.. MOVB (R5)+,@RP ; PICK UP EXP. 40$: MOVB @RP,ESIGN ; SAVE SIGN CMPB #'-,@RP ; IS IT "-" ? BEQ 50$ ; NO CMPB #'+,@RP ; IS IT "+" ? BNE 60$ ; NO 50$: MOVB (R5)+,@RP ; GET NEXT DIGIT 60$: CMP DELIM,@RP ; IS IT BLANK ? BEQ NUMEXP SUB #'0,@RP ; VALID DIGIT ? BMI NUMERR ; NO CMPB R2,@RP ; LESS THAN RADIX ? BLOS NUMERR .IFDF EIS MUL R2,R1 ; MULT. BY RADIX .ENDC .IFNDF EIS MOV R1,R0 ; MULT. BY RADIX MOV R2,R3 61$: DEC R3 BEQ 62$ ADD R0,R1 BR 61$ 62$: .ENDC ADD @RP,R1 ; PLUS DIGIT BR 50$ ; TRY AGAIN NUMEXP: CMPB #'-,ESIGN ; CHECK SIGN BNE 10$ NEG R1 10$: TST @FP ; = 0? BEQ NUMFIN ; YES ADD R1,EEXP ; ADD INTO TOTAL BEQ 30$ ; FINISHED IF ZERO BLT 20$ ; NEGATIVE ? JSR PC,LSHIFT ; NO. SHIFT JSR PC,LSHIFT SUB #2,BEXP JSR PC,SMAN ; SCALE MANTISSA SMUL ; FOR POSITIVE EXP BR 30$ ; DONE 20$: NEG EEXP ; SCALE MANTISSA NEG BEXP ; FOR NEGATIVE EXP JSR PC,SMAN SDIV NEG BEXP 30$: JSR PC,BNORM ; NORMALIZE MOV BEXP,R0 BMI NUMERR ; ERROR IF NEGATIVE CMP #377,R0 ; EXPONENT OVERFLOW? BLT NUMERR SWAB R0 ; POSITION EXPONENT ROR R0 CMPB #'-,SIGN ; IS NUMBER NEGATIVE? BNE 40$ BIS #100000,R0 ; SET SIGN BIT 40$: BIC #177600,@FP ; CLEAR EXPONENT SPACE ADD R0,@FP BR NUMFIN ; ALL DONE NUMSGN: INC PRECIS ; FIX PRECISION CMPB #'-,SIGN ; CHECK SIGN BNE NUMFIN NEG 4(FP) ; NEGATE NEG 6(FP) SBC 4(FP) ; IGNORE SIGN OF TWO HIGH WORDS BPL 10$ MOV #-1,2(FP) MOV #-1,@FP BR NUMFIN 10$: CLR 2(FP) CLR @FP NUMFIN: CMP @RP,DELIM ; PROPER ENDING ? BEQ NUMDON ; YES NUMERR: ADD #4,2(RP) ; ERROR. DROP NUMBER AND ADD #10,FP ; TYPE "?" NUMDON: TST (RP)+ ; POP CHAR. MOV (RP)+,IC ; RESTORE INSTR. COUNTER .NEXT SMAN: MOV #SMA3,R2 ; SCALE MANTISSA SMA1: CMP EEXP,@R2 ; R2 POINTS TO POWER OF TEN BLT SMA2 SUB (R2)+,EEXP ; KNOCK DOWN EXP ADD (R2)+,BEXP ; BUMP UP BINARY EXP MOV @RP,R5 ; FIX MANTISSA JSR PC,@(R5)+ CMP -(R2),-(R2) ; RESET CONSTANTS BR SMA1 ; TRY AGAIN SMA2: ADD #6,R2 ; TRY NEW CONSTANTS CMP R2,#SMA4 ; ALL DONE ? BLO SMA1 ADD #2,@RP ; YES. FIX RETURN POINTER RTS PC ; LEAVE SMA3: 3,12,076400,2,7,062000,1,4,050000 SMA4 = . SMUL: MOV FP,R3 ; GET POINTER ADD #10,R3 JSR PC,FML ; LOW ORDER RESULT MOV R0,@R3 SMUL1: JSR PC,FML ; LOOP ON REST ADD R1,2(R3) ADC R0 MOV R0,@R3 CMP R3,FP ; ARE WE DONE ? BHI SMUL1 RTS PC ; LEAVE FML: .IFDF EIS MOV -(R3),R0 ; PICK UP NEXT WORD MUL @R2,R0 ; R2 POINTS TO MULT. BPL . + 4 ADD @R2,R0 ; FIX FOR LOGICAL ASHC #1,R0 ; RESCALE .ENDC .IFDF EAE MOV #MQ,R1 ; POINT INTO THE EAE CLR R0 ; CLEAR HIGH ORDER RESULT MOV @R2,(R1)+ MOV -(R3),@R1 ; DO MULT. BPL .+4 ADD @R2,R0 ; FIX LOGICAL * CMP -(R1),-(R1) ADD (R1)+,R0 MOV @R1,R1 ASL R1 ROL R0 .ENDC .IFNDF EIS&EAE CLR R0 CLR R1 MOV #20,-(RP) ; PUT COUNT ON RETURN TST -(R3) ; BUMP POINTER FML1: ROR @R3 BCC .+4 ADD @R2,R0 CLC ROR R0 ROR R1 DEC @RP BGT FML1 ASL R1 ROL R0 TST (RP)+ .ENDC RTS PC ; LEAVE SDIV: MOV FP,R3 ; GET POINTER ASR (R3)+ ; DIVIDEND/2 ROR (R3)+ ROR (R3)+ ROR @R3 MOV FP,R3 MOV #3,R5 ; NO. OF LOOPS MOV @R3,R1 ; FIRST ARG. SDIV1: MOV R1,R0 ; LOOP TO DIVIDE MOV 2(R3),R1 JSR PC,FDV MOV R0,(R3)+ DEC R5 BNE SDIV1 MOV R1,R0 ; DO FINAL DIVIDE CLR R1 JSR PC,FDV MOV R0,@R3 RTS PC ; LEAVE FDV: .IFDF EIS ASHC #-1,R0 ; DIVIDE BY 2 ROR -(RP) ; SAVE BIT DIV @R2,R0 ; DO DIVISION .ENDC .IFDF EAE ASR R0 ; DIVIDE BY 2 ROR R1 ROR -(RP) ; SAVE BIT MOV R5,-(RP) ; SAVE POINTER MOV #MQ,R5 ; POINT TO EAE MOV R1,@R5 MOV R0,-(R5) MOV @R2,-2(R5) ; DO DIVISION MOV (R5)+,R1 MOV @R5,R0 MOV (RP)+,R5 .ENDC .IFNDF EAE&EIS ASR R0 ; DIVIDE BY 2 ROR R1 ROR -(RP) ; SAVE BIT MOV R3,-(RP) ; SAVE IT FOR NOW MOV @R2,R3 NEG R3 MOV #20,-(RP) ; SET LOOP COUNT ADD R3,R0 ; INITIAL SUBTRACTION CLR -(FP) ; CLEAR LASTING CARRY BIT FDV1: ROL R1 ; ROTATE ONCE ROL R0 TST @FP ; CHECK LAST CARRY BEQ FDV2 ; =0 => + =1 => - CLR @FP ; CLEAR CARRY ADD R3,R0 ; ONE EXTRA STEP BR FDV3 FDV2: ADD @R2,R0 ; -2N+N=N THIS STEP FDV3: ADC @FP ; MAKE CARRY LAST BEQ .+4 INC R1 ; UPDATE > 0 DEC @RP ; COUNT THIS PASS BGT FDV1 ; DO MORE IF NECESSARY ROR R1 ; FINISH LAST CYCLE BCS FDV4 ; OMIT IF 1 ADD @R2,R0 ; CORRECT REMAINDER CLC FDV4: ROL R1 ; REPLACE LAST BIT CMP (FP)+,(RP)+ ; POP JUNK MOV R0,-(RP) ; SWITCH REMAINDER AND MOV R1,R0 ; QUOTIENT MOV (RP)+,R1 MOV (RP)+,R3 .ENDC ROL (RP)+ ; PICK UP THE BIT ROL R1 ; SCALE REMAINDER ASL R0 ; AND QUOTIENT CMP @R2,R1 ; IS REMAINDER TOO BIG? BHI .+6 ; NO.. INC R0 ; YES.. INC Q SUB @R2,R1 ; FIX REMAINDER RTS PC BNORM: TST @FP ; IS HIGH WORD ZERO ? BNE NOR1 MOV 2(FP),@FP ; YES. SHIFT LEFT WORD MOV 4(FP),2(FP) MOV 6(FP),4(FP) CLR 6(FP) SUB #20,BEXP ; DEC. EXP BMI NOR3 ; IF ZERO, LEAVE BR BNORM ; TEST AGAIN NOR1: CMP #377,@FP ; TOO FAR LEFT ? BHIS NOR2 JSR PC,RSHIFT ; YES. RIGHT SHIFT ONE BIT INC BEXP ; INC EXP BR NOR1 ; TEST AGAIN NOR2: CMP @FP,#200 ; TOO FAR RIGHT ? BHIS NOR3 JSR PC,LSHIFT ; YES. LEFT SHIFT ONE BIT DEC BEXP ; DEC EXP BR NOR2 ; TEST AGAIN NOR3: RTS PC ; LEAVE LSHIFT: ASL 6(FP) ; LEFT SHIFT FOUR WORDS ROL 4(FP) ROL 2(FP) ROL @FP RTS PC ; LEAVE RSHIFT: CLC ; RIGHT SHIFT FOUR WORDS ROR @FP ROR 2(FP) ROR 4(FP) ROR 6(FP) RTS PC ; LEAVE .SBTTL LITERAL CONVERTER .CODE 7,LITE,LITERAL ; ***** LITERAL CMP PRECIS,#2 BHI MODE ; FOUR WORD FLOATING BLO RETN1 ; INTEGER ? MOV (FP)+,2(FP) ; TWO WORD FLOATING MOV (FP)+,2(FP) BR MODE RETN1: BIT (FP)+,(FP)+ ; DROP TWO WORDS INC PRECIS CMP PRECIS,#1 BHI MODE ; TWO WORD INTEGER TST (FP)+ ; ONE WORD INTEGER MODE: TSTB STATE ; COMPILE STATE ? BEQ RETN5 + 4 ; NO MOV DP,R3 ; LOAD DICTIONARY POINTER CMP PRECIS,#2 BHI RETN4 ; FOUR WORDS BEQ RETN2 ; TWO WORDS MOV #LIT,(R3)+ ; ONE WORD LIT CALL MOV (FP)+,(R3)+ BR RETN5 RETN2: MOV #LIT.,(R3)+ ; TWO WORD LIT CALL MOV (FP)+,(R3)+ MOV (FP)+,(R3)+ BR RETN5 RETN4: MOV #LIT..,(R3)+ ; FOUR WORD LIT CALL MOV (FP)+,(R3)+ MOV (FP)+,(R3)+ MOV (FP)+,(R3)+ MOV (FP)+,(R3)+ RETN5: MOV R3,DP ; UPDATE DICTIONARY POINTER .NEXT .ANON LIT.. ; ***** LIT.. ADD #10,IC MOV IC,R0 MOV -(R0),-(FP) MOV -(R0),-(FP) MOV -(R0),-(FP) MOV -(R0),T JMP PUSH1 .ANON LIT ; ***** LIT MOV (IC)+,T ; LOAD SINGLE PARAMETER JMP PUSH1 .ANON LIT. ; ***** LIT. MOV (IC)+,T ; LOAD DOUBLE PARAMETER MOV (IC)+,-(FP) JMP PUSH1 .ENDC ;?????? .SBTTL IMMEDIATE, FORGET AND CONSTANT .CODE 11,IMME,,1 ; ***** IMMEDIATE MOV LAST,R0 ; UP THE PRECEDENCE OF BIS #400,-2(R0) ; THE LAST DEFINED WORD .NEXT .COLON 6,FORG ; ***** FORGET .WORD WORD,FIND,FORG1,SEMI,ABORT0 .ANON FORG1 ; ***** FORG1 TSTB -2(R2) ; LOOK FOR LONG LINK BNE 1$ ; NE => SHORT LINK TST -(R2) ; ADJUST POINTER FOR LL 1$: CMP -(R2),-(R2) ; BACK UP THE NEW DICTIONARY POINTER CMP R2,#DP0 ; DO NOT ALLOW OBJECT PROGRAM TO BE BHI 11$ ; TRUNCATED. IF SO, TRIM AT END MOV #DP0,R2 ; OF OBJECT PROGRAM 11$: MOV #36,R1 ; LOOP COUNT FOR 16 WAY THREAD 2$: MOV HEAD(R1),R0 ; START AT LAST ENTRY OF THREAD 3$: CMP R0,R2 ; TRUNCATE DICTIONARY HERE? BLO 5$ ; YES.. MOVB 2(R0),R3 ; PICK UP LINK BIC #177400,R3 BNE 4$ MOV -2(R0),R3 ; GET THE LONG LINK 4$: ASL R3 ; WORD => BYTE OFFSET SUB R3,R0 ; POINT TO NEXT THREAD ELEMENT BR 3$ ; AND KEEP LOOKING 5$: MOV R0,HEAD(R1) ; RESET THE THREAD SUB #2,R1 ; DO ALL 16 OF THEM BGE 2$ MOV R2,DP ; RESET DICTIONARY POINTER .NEXT .COLON 10,CONS,CONSTANT ; ***** CONSTANT .WORD ENTER,COMMA,SCODE CON: MOV @IC,-(FP) ; MOVE PARAMETER TO STACK MOV (RP)+,IC ; 'SEMI' .NEXT .CONS 4,PUSH,PUSH1 .CONS 3,,PUT1 .CONS 3,,POP1 .CONS 5,COMM,COMMA .CONS 4,BASE,BASE0 .CONS 4,SP00,SP0 .CONS 4,RP00,RP0 .CONS 2,,DP .CONS 5,DELI,DELIM .CONS 4,PREV,PREV .CONS 5,STAT,STATE .CONS 2,,IN .CONS 5,FORT,LDBLK .SBTTL ASSEMBLER OPERANDS .COLON 3,<1OP > ; ***** 1OP .WORD CONSTA,SCODE MOV DP,R3 ; POINT TO NEXT DICTIONARY CELL MOV @IC,@R3 ; ADD IN OPCODE ADD @FP,(R3)+ ; STORE THE OPCODE JSR PC,OPS MOV R3,DP SM1: MOV (RP)+,IC ; 'SEMI' .NEXT .COLON 3,<2OP > ; ***** 2OP .WORD CONSTA,SCODE MOV DP,R3 ; POINT TO NEXT DICTIONARY CELL MOV @FP,R1 ; GET OPERAND SWAB R1 ; PUT IN PROPER PLACE ASR R1 ASR R1 ADD @IC,R1 ; ADD IN OPCODE MOV R1,(R3)+ JSR PC,OPS BIS @FP,@DP JSR PC,OPS MOV R3,DP BR SM1 OPS: MOV @FP,R1 ; GET ANOTHER COPY OF OPERAND BIC #177770,@FP ; LEAVE THE REGISTER ONLY CMP #7,(FP)+ ; FORK IF REGISTER 7 BEQ OPR BIC #177707,R1 ; LEAVE THE MODE ONLY CMP R1,#60 ; INDEXING? BGE OPR1 ; YES.. RTS PC OPR: CMPB R1,#27 ; REGISTER ADDRESSING ONLY? BLT OPR2 BIT #40,R1 ; RELATIVE OR RELATIVE DEFFERED? BEQ OPR1 ; SKIP IF IMM OR ABS SUB R3,@FP ; FIX FOR PROPER ADDRESSING SUB #2,@FP OPR1: MOV (FP)+,(R3)+ ; STORE THE NEXT WORD OPR2: RTS PC .SBTTL ENTRY GENERATOR .ANON PLOC ; ***** PLOC CMP (R2)+,(R2)+ ; BUMP ADDRESS BY 4 .ANON LOC ; ***** LOC CLR PRECIS ; SET SINGLE PRECISION MOV R2,-(FP) JMP MODE .COLON 1,<% >,,1 ; ***** % .WORD WORD,FIND,LOC,SEMI,QUESTN .COLON 1,<' >,,1 ; ***** ' .WORD WORD,FIND,PLOC,SEMI,QUESTN .CODE 5,COUN,COUNT ; ***** COUNT MOV @FP,R2 ; PICK UP TEXT POINTER CMPB @R2,#MAXWRD ; MSG TOO LONG? BHI COUNT1 ; YES .. MOVB @R2,T INC @FP ; PICK UP CHARACTER COUNT JMP PUSH1 COUNT1: CLRB @R2 ; CLEAR CHARACTER COUNT BR QUESTN+2 .ANON ENTRY ; ***** ENTRY JSR PC,CMPRES ; COMPACT ASCII STRING MOV DP,R2 ; USE DICTIONARY POINTER MOV R2,R3 SUB @(FP),R2 ; COMPUTE DISTANCE TO LAST ENTRY ROR R2 ; IN WORDS BIT #177400,R2 ; IS IT A SHORT LINK? BEQ 1$ ; YES.. INC R2 ; COUNT EXTRA WORD MOV R2,(R3)+ ; STORE LONG LINK CLR R2 ; SET SHORT LINK = 0 1$: MOV R3,@(FP)+ ; UPDATE THE HEAD LIST MOV R0,(R3)+ ; SET ENTRY INTO DICTIONARY ADD R2,R1 ; STORE THE LINK MOV R1,(R3)+ ; STORE LAST WORD OF ENTRY MOV R3,LAST ; UPDATE POINTERS MOV R3,DP .NEXT .CODE 5,OCTA ;***** OCTAL MOV #10,R0 2$: MOV R0,BASE0 .NEXT .CODE 7,DECI ;***** DECIMAL MOV #10.,R0 BR 2$ .SBTTL TYPING WORDS .CODE 4,TYPE,TYPE ; ***** TYPE MOV #1,EMPTY ; MARK BUFFER AS EMPTY CMP OUT,MSGTOP ; OUT BUFFER FULL? BLO TYP3 ; NO.. JSR PC,SEND ; TYPE THE BUFFER BR TYPE TYP3: DEC @FP ; MESSAGE TRANSFERRED? BMI TYP4 ; YES.. MOVB @2(FP),@OUT ; MOVE MESSAGE TO BUFFER INC OUT INC 2(FP) BR TYP3 TYP4: CMP (FP)+,(FP)+ ; POP TWO WORDS JMP FPCHK .CODE 2, ; ***** CR CRSND: JSR PC,SEND .NEXT .CODE 5,QUER,QUERY ; ***** QUERY MOV #GO,IC ; RESET TEST INTERPRETER TST SCR ; TEXT FROM KBD OR BLOCK? BGE 20$ ; FROM BLOCK TST EMPTY ; ANY INPUT LEFT BEQ 20$ ; YES.. DEC EMPTY ; FORCE ? BGT 10$ ; GE NO.. JSR PC,SEND ; FORCE 10$: CLR EMPTY JSR PC,RECEIV 20$: .NEXT .CODE 5,ABOR,QUESTN ; ***** ABORT JMP ABORT0 .COLON 1,<( >,,1 ; ***** ( .WORD SETDLM,WORD,SEMI .ANON SETDLM ; ***** SETDLM MOV #'),DELIM .NEXT .SBTTL COMPRESS CMPRES: MOV DP,R3 ; POINT TO WORD STRING CLR -(FP) MOVB (R3)+,@FP ; GET CHARACTER COUNT MOVB @R3,-(RP) ; BUILD HEAD OFFSET BIC #177760,@RP ASL @RP ADD #HEAD,@RP CLR R0 ; INIT ENTRY CLR R1 CMPB #CR,@R3 ; IS THIS A "CRLF"? BNE 11$ ; NO.. BIS #131262,R0 ; YES.. MAKE IT LOOK LIKE BIS #60000,R1 ; A "CRLF" ! BR 3$ 11$: MOV #2000,R2 ; CHARACTER LOOP COUNTER 1$: MOVB (R3)+,-(RP) ; GET ONE CHARACTER AS A TIME SUB #' ,@RP ; CONVERT TO 6 BIT CODE BISB (RP)+,R1 ; BUILD COMPACTED STRING .IFDF EIS CMP #2000,R2 ; 1ST IS SPECIAL BNE 2$ ASH #-4,R1 ; DELETE LOWER 4 BITS 2$: ASHC #6,R0 ; SHIFT UP 1 CHARACTER SPACE SUB #400,R2 BGT 1$ ; DO 4 CHARACTERS ASHC #6,R0 ; POSITION UPPER MOST WORD 1 .IFF CMP #2000,R2 ; 1ST IS SPECIAL BNE 2$ .REPT 4 ASR R1 ; DELETE LOWER 4 BITS .ENDR 2$: JSR PC,SHFT6 ; SHIFT UP 1 CHARACTER SPACE SUB #400,R2 ; DO 4 CHARACTERS BGT 1$ JSR PC,SHFT6 ; POSITION IN UPPER MOST WORD1 .IFTF 3$: MOV (FP)+,R2 ; GET STRING LENGTH SUB #4,R2 ; LENGTH 1-4 => 0, 5-11 => 1-7 BGT 4$ CLR R2 4$: CMP R2,#7 ; CLIP AT 7 BLE 5$ MOV #7,R2 5$: ASL R2 ; POSITION PROPERLY SWAB R2 BIS R2,R1 MOV (RP)+,-(FP) ; RETURN WITH THREAD RTS PC .IFF SHFT6: BIS #6,R2 ; SHIFT LEFT 6 BITS 1$: ASL R1 ROL R0 DECB R2 BGT 1$ RTS PC .ENDC .SBTTL I/O BUFFER CONTROL .ANON CORE ; ***** CORE MOV #PREV,R2 ; CHECK THE PRIMARY BUFFER CMP 2(R2),@FP ; IS THE BLOCK IN CORE? BEQ 2$ ; OK .. LET'S GO MOV #ALT,R0 ; TRY THE ALTERNATE BLOCK CMP 2(R0),@FP ; WELL? BNE 3$ ; NOPE .. READ THE TAPE! JSR PC,SWITCH ; SWITCH THE BUFFERS 2$: MOV @R2,@FP ; BUFFER ADR CMP (IC)+,(IC)+ 3$: .NEXT .CODE 5,FLUS,FLUSH ; ***** FLUSH MOV #PREV,R2 ; LOAD POINTERS MOV #ALT,R0 JSR PC,SWITCH TSTB 5(R2) ; SHOULD THE TAPE BE UPDATED? BEQ FLU1 ; NO .. EXIT MOV PREV+2,R3 ; GET THE BLOCK # FOR OUTPUT ASL R3 .WRITW #BLKA,#0,@R2,,R3 BCS DSKERR CLRB PREV+5 ; RESET THE UPDATE FLAG FLU1: .NEXT SWITCH: MOV R2,T ; MAKE COPY OF ADDRESS POINTER MOV @R0,R3 ; LOAD ALT BUFFER ADDRESS MOV @T,(R0)+ ; MOVE PREV BUFFER ADDRESS TO ALT MOV R3,(T)+ ; AND FINALLY ALT TO PREV MOV @R0,R3 ; NOW FOR BUFFER ID MOV @T,(R0)+ MOV R3,(T)+ MOV @R0,R3 ; AND FINALLY THE UPDATE FLAG MOV @T,@R0 MOV R3,(T)+ RTS PC .ANON DATIN ; ***** DATIN MOV @FP,R3 ; USE BLOCK NUMBER ASL R3 BMI DSKERR ; TREAT AS DISK ERROR MOV PREV,T ; GET BUFFER ADDRESS .READW #BLKA,#0,T,,R3 ; READ ONE FORTH BLOCK BCS DSKERR ; SORRY ABOUT THAT MOV (FP)+,PREV+2 ; SET THE BLOCK NUMBER JMP PUSH1 FCHERR: NTRERR: LOKERR: DSKERR: JMP ABORT0 BLKA: .BYTE 0,10 0,BUFF1,1000,0 .ANON FETCH MOV DP,R3 ; GET DICTIONARY POINTER MOV SP0,R2 ; AND STACK TOP POINTER CMP R2,FP ; CHECK STACK STATE BLOS FCHERR ; LS..STACK UNDERFLOW MOV FP,R1 ; USE COPY OF STACK POINTER 1$: MOV (R1)+,(R3)+ ; COPY INTO FREE MEMORY CMP R1,R2 ; DONE? BLO 1$ ; LO..NO .DSTATUS R3,@DP ; GET DEVICE STATUS BCS FCHERR ; CS..NO DEVICE TST 4(R3) ; RESIDENT HANDLER? BNE 3$ ; NE..YES SUB 2(R3),R2 ; COMPUTE FETCH ADDRESS .FETCH R2,@DP ; GET THE HANDLER BCS FCHERR ; CS..ERROR SUB #10,R2 ; PROVIDE OVERFLOW SPACE MOV R2,R1 ; AND USE FOR NEW STACK 2$: MOV -(R3),-(R1) ; COPY TO NEW STACK SPACE CMP R3,DP ; DONE? BHI 2$ ; HI..NO MOV R2,SP0 ; SET NEW STACK TOP MOV R1,FP ; AND STACK POINTER 3$: .NEXT .COLON 4,DISK,DISK ; ***** DISK .WORD FLUSH,FLUSH,ERASE,FETCH,DISK1,SEMI .ANON DISK1 CLR R1 ; ALWAYS WORK ON CHANNEL 0 .CLOSE R1 ; CLOSE OLD FILE .LOOKUP #LOKBLK,R1,@FP ; AND OPEN UP A NEW FILE BCS LOKERR ; CS..SOME ERROR MOV (FP)+,CHANNL ; SET NEW FILE NAME POINTER .NEXT .CODE 5, ; ***** /LOAD MOV CHANNL,-(RP) ; SAVE CURRENT FILE NAME POINTER MOV @FP,-(FP) ; MOVE THE NEW ONE CLR 2(FP) ; /LOAD BEGINS AT BLOCK 0 JSR IC,@#DISK ; SWITCH DISKS .WORD LOAD,RTSIC ; LOAD NEW DISK AREA MOV (RP)+,-(FP) ; AND RESET FNP BR DISK ;TO CREATE AN RT11 FILE, SAY ; CREATE ; .COLON 6,CREA ; ***** CREATE .WORD FETCH,INTER,SEMI .ANON INTER ASL 2(FP) ; FORTH => RT11 BLOCKS MOV #1,R1 ; ALWAYS USE CHANNEL 1 HERE .ENTER #NTRBLK,R1,(FP)+,@FP ; CREATE DICTIONARY ENTRY 1$: BCS NTRERR ; CS..ERROR SUB #2,@FP .WRITW DP,R1,PREV,#1000,(FP)+ ; WRITE LAST BLOCK BCS 1$ ; CS..ERROR .CLOSE R1 ; CLOSE THE NEW FILE .NEXT .SBTTL BLOCK I/O .COLON 5,BLOC,BLOCK. ; ***** BLOCK .WORD CORE,FLUSH,DATIN,SEMI .CODE 6,UPDA ; ***** UPDATE BISB #-1,PREV+5 ; SET UPDATE FLAG < 0 .NEXT .CODE 12,ERAS,ERASE ; ***** ERASE-CORE MOV #PREV+2,R0 ; GET ADDRESS POINTER MOV #-1,(R0)+ ; ERASE PRIMARY BUFFER INC R0 ; SKIP CHANNEL NUMBER CLRB (R0)+ TST (R0)+ ; AND THE ALTERMATE MOV #-1,(R0)+ INC R0 CLRB @R0 .NEXT .CODE 6,GOOD ;***** GOODBY CLR R0 ;HARD EXIT .EXIT .CODE 4,LOAD,LOAD ; ***** LOAD MOV #1,-(FP) ; START AT BEGINNING OF BLOCK BR LLOAD .CODE 5,LLOA,LLOAD ; ***** LINELOAD MOV IN,-(RP) ; SAVE SOME POINTERS MOV SCR,-(RP) MOV IC,-(RP) DEC @FP ; 0 <= LINE# <= 15 CMP @FP,#15. ; CHECK FOR VALID LINE #'S BHI LINERR ; HI => INVALID SWAB @FP ; * 64 ASR @FP ASR @FP MOV (FP)+,IN ; SET CHARACTER POSITION IN BUFFER MOV (FP)+,SCR ; SET NEW BLOCK NUMBER MOV #GO,IC ; SET UP INTERPRETER .NEXT LINERR: JMP ABORT0 .CODE 2,<;S > ; ***** ;S LAST0= . MOV (RP)+,IC ; RESTORE INPUT STREAM MOV (RP)+,SCR MOV (RP)+,IN .NEXT .SBTTL STARTUP AND REENTER CODE FOR RT11 NOP ; RT11 REENTER LOCATION BEGIN: MOV #FREE,@#USRSWP ; SET UP SWAP AREA FOR USR .SETTOP #-2 ; GET ALL OF MEMORY MOV RP,RP0 ; INIT RETURN STACK BASE MOV R0,SP0 ; AND THE PARAMETER STACK BASE .TRPSET #TRPA,#TRAPS ; NOTIFY RT11 FOR TRAP USAGE .SFPA #TRPA,#TRAPS ; FLTG PT AS WELL .IFDF SCCA .SCCA #TRPA,#SCCAF ; CTRL-C INTERCEPT .ENDC BIS #020000,@#JSW ; SET TO REENTER MOV #FNAME,R4 ; GET FILE NAME ADDRESS MOV #DSTATA,R3 ; MAKE SURE ALL IS WELL .DSTATUS R3,R4 BCS 3$ ; CS..PROBLEMS TST 4(R3) ; IS THE HANDLER IN CORE? BNE 1$ ; NE..YES SUB 2(R3),SP0 ; MAKE ROOM FOR HANDLER .FETCH SP0,R4 ; AND BRING INTO CORE BCS 3$ 1$: .LOOKUP #LOKBLK,#0,R4 ; LOOK FOR THE FILE BCS 3$ .IFDF LPDEV MOV #LPNAME,R4 ; NOW GET THE LP HANDLER .DSTATUS R3,R4 BCS 3$ ; CS..PROBLEMS TST 4(R3) ; IS LP HANDLER RESIDENT? BNE 2$ ; NE..YES SUB 2(R3),SP0 ; MAKE SOME ROOM HERE .FETCH SP0,R4 ; GET THE LP HANDLER BCS 3$ .ENDC 2$: .ENTER #NTRBLK,#11,R4 ; CREATE A FILE BCS 3$ ; IF CS ERROR SUB #10,SP0 ; ALWAYS LEAVE SOME SLOP JMP ABORT0 3$: .PRINT #OPNERR .EXIT .CSECT $$$$DP DP0: ; THIS STARTS THE USER DICTIONARY .BYTE HELLO1-HELLO0 HELLO0: .BYTE CR,LF .ASCII 'CALTECH-DECUS RT11 FORTH 18-OCT-78' .BYTE CR,LF .IFDF AUTOLD .ASCII '(FORTH LOAD)' .IFF .ASCII 'HELLO' .ENDC .BYTE 7 ;BELL HELLO1: .EVEN FREE: .END BEGIN