;********* ; * ; BASIC2 * ; * ;********* .TITLE BASIC2 ; ; OBJECT MODULE FOR PART 2 0F MAIN BASIC INTERPRETER 8JUNE 72 ; ; DOS VERSION FROM WHICH THE RSX VERSION EVOLVED WAS ORIGIANLLY A DECUS ; LIBRARY PROGRAM MODIFIED BY FRANK KORZENIEWSKI OF RPSLMC. ; ; MODIFIED FOR USE UNDER RSX-11D ; BY: LARRY SIMPSON ; MICHAEL REESE MEDICAL CENTER ; JULY-OCTOBER 1975 ; ; MODIFIED TO CLOSE ALL USER FILES ON 6-APR-76 ; ;CODE TO CONVERT TRAP SUBROUTINE CALLS TO NORMAL JSR'S ;FOR OPERATION UNDER RSX. ; ;DEFINE A GENERAL MACRO TO GENERATE A SECOND MACRO WHICH ;CONVERTS A TRAP NAME OF XXXXXX TO A ; JSR PC,XXXXXX ; .MACRO TRPSUB A,B .MACRO A JSR PC,B .ENDM .ENDM ; ; NOW ALL THE ONE-TIME TRAPS THAT BASIC USES ; TRPSUB ATOF,ATOF00 ;ASCII TO FLOATING TRPSUB ATOI,ATOI00 ;ASCII TO INTEGER TRPSUB CLRUSR,CLRU00 ;CLOSE TEMP USER SPACE (IF ANY) TRPSUB CRLF,CRLF00 ;DO [CR,LF] TRPSUB DIMCHK,DIMC00 ;CHECK LEGALITY OF DIMENSIONS TRPSUB EVAL,EVAL00 ;EVALUATE ARITHMETIC EXPRESSION TRPSUB EVALS,EVLS00 ;EVALUATE STRING EXPRESSION TRPSUB FINDLN,FIND00 ;FIND LINE NUMBER (IN R0) TRPSUB GETVAR,GETV00 ;GET TRUNCATED VARIABLE TRPSUB JUNKIT,JUNK00 ;SKIP OVER TRASH TO END OF LINE TRPSUB PACK,PCK00 ;PACK LINE INTO WORKING STORAGE TRPSUB PRINTC,PRNT00 ;PRINT CHARACTER TRPSUB PRINTL,PRN00 ;PRINT LINE, R0=FBA,R1=LBA TRPSUB PRNTLN,PRLN00 ;PRINT LINE NUMBER TRPSUB PUSH,PUSH00 ;PUSH ONE WORD INTO USER LIST TRPSUB SKIP,SKIP00 ;SKIP OVER SPACES IN INPUT TEXT TRPSUB SRCHLF,SRCH00 ;SEARCH FOR LINE FEED USING R1 AS POINTER TRPSUB SRLST,SRL00 ;SEARCH FOR ITEM IN USER STORAGE TRPSUB STRLEN,STRL00 ;COMPUTE STRING LENGTH TRPSUB TSTCH,TST00 ;TEST CHAR (IN R2) ALPHA VS NUMERIC TRPSUB TSTOK,TSTU00 ;CHECK, IS THERE ENOUGH USER SPACE TRPSUB FNMBR,FNMB00 ;GET FILE NUMBER AND SET UP FILE .SBTTL GLOBALS AND DEFINITIONS ; ; GLOBALS--ERROR CALLS ; .GLOBL GOERR, RETERR, DIMERR, DMVERR, DMDERR .GLOBL DEFERR, PARERR, OVFERR, ILFERR, NXVERR .GLOBL LETERR, OPRERR, IFERR, PRNERR, INPERR .GLOBL IN1ERR, IN2ERR, IN3ERR, REAERR, RE1ERR .GLOBL RE2ERR, FORERR, NXTERR, NXMERR, SBSERR .GLOBL STXERR FNMERR LNNERR ; ; GLOBALS--RETURNS TO MAIN ; .GLOBL INIT00 INIT02 INIT10 INIT13 .GLOBL OLD01 CLSEAL FIND01 ; ; GLOBALS--REFERENCES TO FPP ; .GLOBL PWRF00 .GLOBL SINE00, COS00, ATN00, EXPF00, LOG00 .GLOBL ABS00, SQRT00, INT00, RND00, SGN00 .GLOBL FTOA00, M.I ; ; GLOBALS--SYSTEM VARIABLES ; .GLOBL DATI LINENO RUNF USR LASTEX .GLOBL STUDAT ENUDAT S.DATA S.NEXT S.EOS1 .GLOBL PARLST P.ERCD P.LINE P.FCS .GLOBL STCOUN S.EOL1 S.EOL2 S.EOS1 ; ; GLOBALS--ENTRY POINTS ; .GLOBL STOP00, RUN00, GOSB00, GOTO00, RES00 .GLOBL RET00, DIM00, DEF00, EVAL00, GTP00 .GLOBL LET00, IF00, PR00, INP00 EOSCHK .GLOBL READ00, FOR00, NEXT00, REM00, STOP02 .GLOBL RUN01 EVLS00 STRCMP INP01 ONGT00 .GLOBL ATTACH DETACH GOTO02 GOTO03 GOTO04 .GLOBL GETHDR GTOFFS GETNUM STONUM GETSTR .GLOBL STOSTR NEWVAR STRADD WRITBK ; ; PART 2 OF MAIN INTERPRETER ; ; ; REGISTER ASSIGNMENTS ; R0 = %0 ;TEMPORARY AND PARAMETER TRANSFER R1 = %1 ;TEMPORARY AND PARAMETER TRANSFER R2 = %2 ;SCRATCH R3 = %3 ;SCRATCH R4 = %4 ;SCRATCH R5 = %5 ;USER LIST POINTER SP = %6 ;BASIC STACK POINTER PC = %7 ;PROGRAM COUNTER ; AC0 = %0 ;F.P. REGISTER 0 AC1 = %1 ;F.P. REGISTER 1 AC2 = %2 ;F.P. REGISTER 2 AC3 = %3 ;F.P. REGISTER 3 AC4 = %4 ;F.P. REGISTER 4 AC5 = %5 ;F.P. REGISTER 5 ; ; RSX MACRO CALLS .MCALL DIR$ WAIT$ READ$ WRITE$ ; ; LOCAL MACROS ; ; ; PSECT DEFINITIONS ; .PSECT BASIC2,RW,I,GBL,REL,CON,LOW ;PSECT FOR RO CODE ; ; ATTACH AND DETACH PROCESSING CODE ; ATTACH: MOV #IO.ATA,ATTDET+Q.IOFN BR COMATD DETACH: MOV #IO.DET,ATTDET+Q.IOFN COMATD: DIR$ #ATTDET RTS PC ;+1 ; .TP 6 ; .SL ; .ID -5 ; ^CONTROL ^O ; .BR ; .X ^CONTROL ^O ; .X _^^O ; ^CONTROL-^O (_^^O) WILL STOP ALL OUTPUT FROM A ^^LIST\\ COMMAND ; AND RESUME PRINTING WITH ^^READY\\. ; ^IT ALSO STOPS ALL PRINTING FOLLOWING A ^^RUN\\ COMMAND INCLUDING ; NON-FATAL ERRORS. ; ^PRINTING RESUMES WITH A ^^STOP\\ OR _^^C OR A FATAL ERROR (ONE ; WHICH STOPS PROGRAM EXECUTION). ;- .SBTTL STOP00 - STOP AND END STATEMENTS ;+3 ; .SKIP ; .X ^^STOP\\ ; .X ^^END\\ ; .INDENT -5 ; ^^STOP\\ ; .BREAK ; ^^STOP\\ AND ^^END\\ STATEMENTS. ; ^STOP USER PROGRAM EXECUTION AND TELL USER WHERE PROGRAM HAS STOPPED. ; .BREAK ; ^EXAMPLE: ; .NOFILL ; ^^ ; 10 STOP ; 20 END ; \\ ; .FILL ;- ; REGISTERS USED - R0,R1,R2,R3,R4 ; STOP00: JSR PC,DETACH ;NULLIFY ^O MOV #TINPT,INPT ;RE-ASSERT TERMINAL I/O MOV #TOTPT,OTPT ;IN CASE DOING FILE I/O CRLF MOV #STOP01,R0 ;TELL USER PRINTL ; THAT ALL HAS STOPPED PRNTLN ; AT SOME FUNNY PLACE CRLF ;AND THEN STOP02: MOV ENDSTK,SP ;RESTORE THE STACK MOV LINENO,LASTEX ;SAVE LAST EXECUTED LINE NO. CLR LINENO JMP INIT00 ; ASK WHAT NEXT STOP01: .ASCIZ /STOP AT LINE / .EVEN .SBTTL RUN00 - START PROGRAM EXECUTION ;+2 ; .SKIP ; .X ^^RUN\\ ; .INDENT -5 ; ^^RUN\\ ; .BREAK ; ^MAY BE USED IN IMMEDIATE MODE TO START PROGRAM EXECUTION OR BY ; SPECIFYING A FILE IN QUOTES TO RUN ANOTHER ^^BASIC\\ PROGRAM ; STORED ON DISK. ; ^IN PROGRAM MODE, IT MAY BE USED WITH A FILE SPECIFIER TO CHAIN ; TO ANOTHER PROGRAM. ; ^THE ASSUMED FILE EXTENSION IS ^^.BAS\\. ; ^NOTE THAT NO DATA IS SAVED ACROSS A ^^"RUN"\\ TYPE CHAIN. ; ^USER LOADED SUBROUTINES ARE ALSO UNLOADED. ; ^TO PRESERVE DATA AND USER FILES, USE ^^"CHAIN"\\ COMMAND. ; ^A PREVIOUS RESTRICTION AGAINST USING A VARIABLE IN THE ; STRING EXPRESSION FOLLOWING THE R5 2$: MOV #13507,M.I ;RESET RANDOM NUMBER GENERATOR JSR PC,ATTACH ;ATTACH TERMINAL JMP INIT13 ;GO BACK AND LOOK FOR LINE TO DO .SBTTL GOSB00 - GOSUB STATEMENT ;+3 ; .SKIP ; .X ^^GOSUB\\ ; .X ^^GOTO\\ ; .INDENT -5 ; ^^ ; GOSUB N ; .INDENT -5 ; GOTO N ; \\ ; .BREAK ; ^TRANSFERS PROGRAM CONTROL TO STATEMENT ^N, WHERE ^N CAN BE A ; POSITIVE INTEGER CONSTANT OR AN EXPRESSION WHICH WILL BE TRUNCATED ; TO AN INTEGER. ; ^NOTE THAT AN EXPRESSION WILL NOT PRODUCE CORRECT RESULTS IN THE ; EVENT OF A RESEQUENCE. ; .BREAK ; ^EXAMPLE: ; .NOFILL ; ^^ ; 10 GOTO 50 ; 20 GOSUB A(I) ; \\ ; .FILL ;- ; GOSB00 - GOSUB STATEMENT, PUSH CLASS 1 ITEM ON STACK THEN DO A GOTO ; REGISTERS USED - R0,R1,R2,R3,R4 ; TWO16: .FLT2 65536. ;2^16 TWO15: .FLT2 32768. ;2^15 GOSB00: MOV #4,R0 ;CHECK FOR 4 BYTES SPACE TSTOK ;AND INITIALIZE R5 WITH STUDAT BHIS 1$ ;IF OK, BRANCH OVFERR 1$: MOV STGOSB,R5 ;GET START OF GOSUB/RETURN PTRS -> R5 MOV LINENO,-(R5) ;PUT IN PRESENT LINE NUMBER MOV STCOUN,-(R5) ;AND STATEMENT COUNT MOV R5,STGOSB ;AND SET UP NEW START OF PTRS .SBTTL GOTO00 - GOTO STATEMENT ; ; GOTO00 - GOTO STATEMENT - RESET LINENO TO NEW EXECUTION POINT ; REGISTERS USED - R0,R1,R2,R3,R4 ; GOTO00: CLR -(SP) ;INDICATE EXACT MATCH WANTED GOTO04: EVAL ;ARGUMENT FROM R1 LIST TO NUMBER IN AC0 TSTF AC0 ;CHECK FOR NEGATIVE CFCC BLE 1$ ;IF NEG, ERROR CMPF TWO16,AC0 ;CHECK OUR RANGE CFCC BGT 2$ ;IF IN RANGE, BRANCH 1$: LNNERR ;ELSE ERROR 2$: CMPF TWO15,AC0 ;ARE WE IN UNSIGNED REGION CFCC BGT 3$ ;IF NOT (1-32767), BRANCH SUBF TWO16,AC0 ;IF SO, MAKE NEGATIVE FOR CONVERSION 3$: STCFI AC0,R0 ;CONVERT TO INTEGER GOTO03: MOV STUDAT,R1 ;SET UP LOW # LINE PTR MOV BOLNHD,R2 ;AND HIGH # LINE PTR TST LINENO ;CHECK WHERE WE CAME FROM BEQ 2$ ;IF ZERO (IMMEDIATE), BRANCH CMP R0,LINENO ;CHECK REQUESTED AGAINST CURRENT BHI 1$ ;IF FARTHER ON, BRANCH MOV LINEHD,R2 ;IF SAME OR BEFORE, SET NEW HIGH FOR RANGE BR 2$ 1$: MOV LINEHD,R1 ;SET NEW LOW FOR SEARCH RANGE 2$: JSR PC,FIND01 ;AND DO MODIFIED FIND BNE GOTO01 ;IF NOT EXACT, BRANCH GOTO02: TST RUNF ;RUN FLAG SET? BNE 1$ ;IF SO, SKIP INC RUNF ;IF NOT, SET IT JSR PC,ATTACH ;AND MAKE SURE ATTACHED 1$: TST (SP)+ ;POP OFF FLAG TSTB TRCFLG ;TRACE WANTED? BEQ 2$ ;IF NOT, BRANCH CLR STCOUN ;IF SO, CLEAR THE STATEMENT COUNT JSR PC,TRCLIN ;AND GO PRINT TRACE MESSAGE 2$: JMP INIT13 GOTO01: TST (SP) ;EXACT MATCH REQUIRED? BEQ 1$ ;IF SO, ERROR SUB #4,R5 ;ELSE POINT TO FOLLOWING LINE HEADER BR GOTO02 ;AND FINISH PROCESSING 1$: GOERR TRCLIN: PRNTLN ;PRINT THE LINE NUMBER WE'RE AT MOV #TRCMSG,R0 ;ADDRESS OF MESSAGE FOR TRACE PRINTL ;PRINT IT MOV (R5),R1 ;LINE # TO BRANCH TO -> R1 JSR PC,PRLN01 ;PRINT IT MOV #TRCMS2,R0 ;NEXT PART OF MESSAGE PRINTL MOV STCOUN,R1 ;STATEMENT COUNT -> R1 INC R1 ;MAKE R1 STATEMENT WE'RE GOING TO JSR PC,PRLN01 ;PRINT IT OUT CRLF ;END THE LINE RTS PC TRCMSG: .ASCIZ / BRANCH TO LINE / TRCMS2: .ASCIZ / STMT / .EVEN .SBTTL ON GOTO .SBTTL ON GOSUB ;+3 ; .SKIP ; .X ^^ON _ GOTO _\\ ; .X ^^ON _ GOSUB _\\ ; .ID -5 ; ^^ ; ON _ GOTO _ ; .ID -5 ; ON _ GOSUB _ ; \\ ; .BR ; ^THIS STATEMENT TRANSFERS CONTROL TO THE ^NTH LINE NUMBER IN THE LIST. ; ^THE EXPRESSION IS EVALUATED AS A NORMAL R0 (INTEGER) BLE 1$ ;ZERO OR NEG => ERROR SKIP ;GET NEXT BYTE CMPB R2,#S.GOTO ;CHECK FOR PROPER BEQ 3$ ;CODES - GOTO CMPB R2,#S.GOSB ;OR GOSUB BEQ 3$ ;ELSE NOT A UNRERR ;RECOGNIZED STATEMENT 3$: MOV R2,-(SP) ;SAVE A BYTE CODE DEC R0 ;DECREMENT FOR COMMA COUNT BEQ 6$ ;IF ZERO, BRANCH 4$: SKIP ;GET NEXT CHAR CMPB R2,#', ;IS IT A COMMA? BEQ 5$ ;IF SO, GO THROUGH LOOP COUNT CMPB R2,#S.EOS1 ;IS IT END OF STATEMENT? BHIS 1$ ;IF SO, ERROR BR 4$ ;IF NOT, KEEP LOOKING FOR COMMA 5$: SOB R0,4$ ;KEEP COUNTING COMMAS 6$: CMP (SP)+,#S.GOTO ;WAS THE CODE A GOTO? BEQ 7$ ;IF SO, BRANCH JMP GOSB00 ;IF NOT, MUST HAVE BEEN A GOSUB 7$: JMP GOTO00 .SBTTL RES00 - RESTORE STATEMENT ;+3 ; .SKIP ; .X ^^RESTORE\\ ; .X ^FILE RESTORE ; .INDENT -5 ; ^^ ; RESTORE ; \\ ; .BREAK ; ^RESETS DATA POINTER TO START OF DATA STATEMENTS. ; ^FOR FILES, THE ^^RESTORE\\ STATEMENT MAY BE FOLLOWED BY A _# ; SIGN AND AN ARITHMETIC EXPRESSION GIVING THE FILE NUMBER. ; ^A SEQUENTIAL FILE OPEN FOR READ ONLY WILL BE RESET TO THE ; START. ; ^TO READ A SEQUENTIAL FILE CURRENTLY BEING WRITTEN, IT IS NECESSARY ; TO CLOSE AND THEN RE-OPEN FOR READ. ; .BREAK ; ^EXAMPLE: ; .NOFILL ; ^^ ; 10 RESTORE ; \\ ; .FILL ;- ; RES00 - RESTORE STATEMENT - CLEAR THE DATA POINTER ; REGISTERS USED - NONE ; RES00: SKIP ;GET NEXT CHAR CMP R2,#'# ;FILE NUM FOLLOWING? BNE 1$ ;IF NOT, DO DATA RESTORE MOV #400,R0 ;SET FOR INPUT OK JSR PC,FILFND ;FIND THE FILE CONTROL BLOCK BNE 3$ ;IF FOUND, BRANCH FNMERR ;ELSE ERROR 3$: BIT #3000,(R3) ;CHECK FOR RANDOM OR OUTPUT BITS BNE 4$ ;IF EITHER, IGNORE STATEMENT MOV R1,-(SP) ;SAVE TEXT POINTER MOV R3,R0 ;GET FDB ADDRESS ADD #26,R0 ;IN R0 CLR R1 ;SET UP FIRST MOV #1,R2 ;BLOCK AND ZEROTH CLR R3 ;BYTE FOR .POINT JSR PC,.POINT ;RESET FILE TO START MOV (SP)+,R1 ;RESTORE TEXT POINTER 4$: JMP INIT02 ;GO BACK TO INTERPRETER 1$: CLR DATI ;DO DATA RESTORE DEC R1 ;BACK UP TEXT POINTER BR 4$ .SBTTL RET00 - RETURN STATEMENT ;+3 ; .SKIP ; .X ^^RETURN\\ ; .INDENT -5 ; ^^ ; RETURN ; \\ ; .BREAK ; ^RETURNS TO STATEMENT FOLLOWING ^^GOSUB\\ WHICH GOT YOU HERE. ; ^OTHER STATEMENTS MAY FOLLOW A GOSUB ON A LINE. ; ^IF THE LINE CONTAINING A R3 CMP R3,STFONX ;ANYTHING THERE? BHIS RET03 ;IF NOT, REPORT ERROR MOV R3,-(SP) ;SAVE THIS ADDRESS FOR LATER RET02: MOV 2(R3),R0 ;LINE NUMBER -> R0 BEQ 3$ ;IF ZERO, BRANCH FINDLN ;POSITION TO IT BNE RET03 ;IF NOT FOUND, BIG TROUBLE MOV (SP)+,R3 ;GET BACK LAST ADDRESS MOV (R3),R2 ;GET COUNT OF STATEMENTS JSR PC,STFIND ;FIND PLACE IN LINE (PRINT MESSAGE IF TRACE) ADD #4,STGOSB ;UPDATE PTR AREA PTR JMP INIT03 ;AND CONTINUE IN CODE 3$: ADD #4,STGOSB ;DELETE GOSUB ITEM FROM PTR AREA JMP STOP02 RET03: RETERR ; ; STATEMENT FIND ROUTINE TO POSITION OURSELVES TO PROPER STATEMENT ; IN A LINE (USED FOR RETURN AND NEXT STATEMENTS) ; ON ENTRY: ; R0 HAS LINE NUMBER ; R5 HAS LINE HEADER ; R1 POSITIONED TO START OF LINE ; R2 HAS COUNT OF STATEMENTS TO SKIP ; ; ON EXIT: ; R0 -> LINENO ; R5 -> LINEHD ; R1 AT START OF R2+1 STATEMENT ; R2 UNDEFINED ; STFIND: MOV R0,-(SP) ;SAVE LINE NUMBER MOV R2,STCOUN ;UPDATE STATEMENT COUNT NOW 2$: INC R1 ;PUSH PAST POSSIBLE STATEMENT TERMINATOR ; ; FOLLOWING CODE IS TO MAKE SURE AN ELSE JUST AFTER A STATEMENT TERMINATOR ; (MEANING A COMMENT IN PREVIOUS LINE) DOES NOT GET COUNTED TOO MANY TIMES ; MOV R2,-(SP) ;SAVE R2 SKIP ;POSITION R1 TO JUST PAST 1ST SIG. BYTE DEC R1 ;AND BACK IT UP TO SIG. BYTE MOV (SP)+,R2 ;GET BACK R2 CMPB (R1),#S.ELSE ;IS IT ELSE BNE 3$ ;IF NOT, DO REGULAR PROCESS INC R1 ;IF SO, PUSH PAST IT ; 3$: JUNKIT ;GET TO END OF STATEMENT SOB R2,2$ ;DO IT R2 TIMES TSTB TRCFLG ;TRACE WANTED? BEQ 1$ ;IF NOT, BRANCH MOV R1,-(SP) ;SAVE TEXT PTR WE'VE WORKED SO HARD TO SET JSR PC,TRCLIN ;GO PRINT MESSAGE MOV (SP)+,R1 ;RESTORE OUR TEXT PTR 1$: MOV (SP)+,LINENO ;NOW SET LINE NUMBER MOVB (R1)+,R2 ;TERMINATOR -> R2 MOV R5,LINEHD ;AND LINE HEADER RTS PC .SBTTL DIM00 - DIM STATEMENT ;+3 ; .SKIP ; .X ^^DIM\\ ; .X ^STRING VARIABLES ; .INDENT -5 ; ^^ ; DIM ; \\ ; .BREAK ; ^DECLARES SIZE OF ARRAYS AND STRINGS. ; ^ALSO SPECIFIES STRINGS AS EITHER FIXED OR VARIABLE LENGTH. ; ^ARRAYS MAY HAVE ONE OR TWO SUBSCRIPTS. ; ^STRING LENGTHS ARE INDICATED IN SQUARE BRACKETS [#] WHICH ARE ; FOLLOWED BY A '^V' IF THE STRING IS TO HAVE VARIABLE LENGTH. ; ^IN THE CASE OF A VARIABLE LENGTH STRING, THE LENGTH IS THE ; MAXIMUM LENGTH WHICH THE STRING MAY ASSUME. ; ^A STRING UNDECLARED IN A R2 CMPB R2,#'# ;IS THIS A VIRTUAL ARRAY DIMENSION? BEQ DIM01 ;IF SO, BRANCH TO THAT ROUTINE DEC R1 ;ELSE BACK UP TEXT PTR DIM02: JSR PC,GETHDR ;VARIABLE NAME -> R4 ETC. BVS DIM99 ;IF ERROR, REPORT IT BNE DIM97 ;OR IF USED ALREADY, DIFFERENT ERROR MOV R4,-(SP) ;SAVE 2 CHAR NAME (SIX BITS EACH) MOV R0,-(SP) ;SAVE TYPE OFFSET CMP R0,#10 ;IS IT STRING? BEQ 2$ ;IF SO, BRANCH JSR PC,SUBONE ;AND GO GET SUBSCRIPTS BVS DIM99 ;IF ERROR, REPORT IT MOV (SP)+,R2 ;TYPE OFFSET -> R2 MOV R0,-(SP) ;SAVE DIM INFO INC R3 ;ADD ONE TO EACH INC R4 ;DIMENSION MUL R4,R3 ;PRODUCT -> R3 BIT #160000,R3 ;TOO BIG? BNE DIM98 ;IF SO, DECLARE OVERFLOW MOV R3,R0 ;COPY # OF VARIABLES -> R0 ASH 8$(R2),R0 ;SHIFT BY APPROPRIATE AMOUNT INC R0 ;ROUND UP, IN CASE BIC #1,R0 ;AN ODD # OF BYTE VARIABLES MOV R0,-(SP) ;SAVE ON STACK ADD #4,R0 ;ADD HEADER + DIM INFO TSTOK ;CHECK FOR ROOM (ENUDAT -> R5) BLO DIM98 ;IF NOT ENOUGH ROOM, DECLARE OVERFLOW ADD R5,R0 ;R0 POINTS TO NEW END OF DATA MOV R0,ENUDAT ;SET NEW END OF DATA MOV (SP)+,R3 ;RESTORE # OF FLOATING TOTAL BYTES ASR R3 ;NOW # OF WORDS MOV (SP)+,R2 ;POP DIM INFO MOV (SP)+,(R5)+ ;HEADER -> DATA AREA MOV R2,(R5)+ ;DIM INFO -> DATA AREA 1$: CLR (R5)+ ;CLEAR THE AREA SOB R3,1$ ;R3 TIMES BR 7$ ;AND GO TO FINAL FINISH 8$: .WORD 2 ;REAL*4 .WORD 1 ;INTEGER .WORD 0 ;BYTE .WORD 3 ;REAL*8 ; ; STRING SECTION ; 2$: JSR PC,STRGLN ;GO GET SIZE OF INDIVIDUAL ELEMENT BVS DIM99 ;IF ERROR, BRANCH MOV R0,(SP) ;SAVE LEN WITH SIGN (OVER TYPE CODE) BPL 3$ ;NOW GET NEG R0 ;ABSOLUTE VALUE 3$: DIMCHK ;AND CHECK ITS RANGE BNE DIM99 ;BRANCH IF ERROR MOV R0,-(SP) ;SAVE ABS VALUE JSR PC,SUBONE ;R3,R4 WITH INDIVIDUAL DIMS, R0 PACKED BVS DIM99 ;REPORT ERROR MOV R1,-(SP) ;SAVE TEXT PTR MOV R0,R1 ;COPY PACKED SUBSCRIPTS -> R1 MOV 2(SP),R0 ;ABS LEN OF INDIVIDUAL STRING -> R0 MOV R1,2(SP) ;PACKED SUBSCRIPTS ON STACK STRLEN ;GET TOTAL STRING LEN -> R0 ADD #6,R0 ;ADD 3 HEADER WORDS TSTOK ;CHECK FOR ROOM BLO DIM98 ;IF NOT ENOUGH, REPORT ERROR MOV (SP)+,R1 ;TEXT PTR MOV (SP)+,R3 ;PACKED DIMS MOV (SP)+,R2 ;LEN WITH SIGN MOV (SP)+,(R5)+ ;HEADER -> DATA AREA MOV R3,(R5)+ ;PACKED DIMENSIONS TST R2 ;FIXED OR VARIABLE? BPL 4$ ;IF FIXED, BRANCH NEG R2 ;IF VARIABLE, MAKE ABS VALUE BIS #177400,R2 ;WITH HIGH BYTE -1 4$: MOV R2,(R5) ;PUT LEN AND TYPE AWAY BIS #400,(R5)+ ;MAKE SURE NON-ZERO HIGH BYTE SUB #6,R0 ;GET LEN INDEP. OF 3 HEADER WORDS ASR R0 ;CONVERT LEN TO WORDS 5$: CLR (R5)+ ;AND CLEAR IT ALL SOB R0,5$ ;OUT (NULLS) MOV R5,ENUDAT ;RECORD NEW END OF DATA 7$: SKIP ;NEXT CHAR -> R2 CMPB R2,#', ;SOMETHING TO FOLLOW? BEQ DIM00 ;IF SO, DO IT AGAIN DEC R1 ;IF NOT, BACK UP TEXT PTR JMP INIT02 DIM97: DMDERR ;PREVIOUSLY USED NAME DIM98: DMVERR ;OVERFLOW DIM99: DIMERR ;BAD DIMENSION ;+3 ; .S ; .X ^^DIM#_#\\ ; .X ^VIRTUAL ARRAYS ; .ID-5 ; ^^ ; DIM#_#\\EXP ; .BREAK ; ^THIS STATEMENT DECLARES CERTAIN VARIABLES AS "VIRTUAL ARRAYS" AND DEFINES ; THEIR ALLOCATION ON THE FILE WHOSE AC0 STCFI AC0,R0 ;INTEGER -> R0 BLE DIM99 ;NEG OR ZERO IS ERROR CMP R0,#OP.MXL ;CHECK AGAINST MAX LUN BHI DIM99 ;ALLOWED, IF TOO BIG, ERROR MOV R0,-(SP) ;SAVE IT FOR FUTURE USE CLR -(SP) ;SET ACCUMULATED OFFSET CLR -(SP) ;32 BIT ZERO SKIP ;NEXT CHAR SHOULD BE CMPB R2,#', ;COMMA BNE DIM99 ;ELSE ERROR 1$: JSR PC,GETHDR ;VARIABLE NAME -> R4 BVS DIM99 ;IF SYNTAX ERROR, BRANCH BNE DIM97 ;IF ALREADY USED, BRANCH BIS #10000,R4 ;SET VIRTUAL FLAG MOV R4,-(SP) ;AND SAVE NAME AND FLAG MOV R0,-(SP) ;SAVE JUMP PTR SUB #10,R0 ;DO WE HAVE STRING? BGE 3$ ;IF SO, BRANCH JSR PC,SUBSUB ;GET SUBSCRIPTS BVS DIM99 ;REPORT ANY ERROR MOV (SP)+,R0 ;JUMP OFFSET -> R0 MOV 7$(R0),R2 ;ELEMENT LENGTH -> R2 MOV R2,-(SP) ;AND ON STACK BR 2$ ;GO TO COMMON FINISHING CODE 7$: .WORD 4 ;SINGLE PRECISION FLOATING .WORD 2 ;INTEGER (16 BIT) .WORD 1 ;BYTE .WORD 10 ;DOUBLE PRECISION ; ; STRING SECTION ; 3$: JSR PC,STRGLN ;GET LENGTH OF INDIVIDUAL STRING ELEMENT MOV R0,(SP) ;SAVE SIGNED LENGTH (OVER JUMP PTR) BPL 4$ ;NOW GET NEG R0 ;ABS VALUE 4$: MOV R0,-(SP) ;SAVE ABS VALUE ON STACK MOV #12,R2 ;UP TO 12(8) BITS CLR R3 ;THIS IS THE BIT COUNTER 5$: ASR R0 ;SHIFT BITS OUT BCC 6$ INC R3 ;AND COUNT THEM 6$: SOB R2,5$ ;WE SHOULD HAVE DEC R3 ;ONLY 1 BIT IF BNE DIM99 ;LENGTH IS POWER OF 2 (0 NOT ALLOWED) TST R0 ;NOTHING SHOULD BE LEFT IN R0 EITHER BNE DIM99 ;ELSE BIGGER THAN A BLOCK JSR PC,SUBSUB ;GET ARRAY SUBSCRIPTS MOV (SP)+,R2 ;ABS LEN -> R2 BR 2$ ;AND FINISH UP ; ; COMMON CODE FOR VIRTUAL DIMENSION STATEMENT ; ; ON ENTRY (VIA JUMP OR BRANCH) ; R2 HAS POSITIVE SIZE OF INDIVIDUAL ELEMENT (MUST BE A POWER OF 2) ; R3 HAS THE FIRST SUBSCRIPT ; R4 HAS THE 2ND SUBSCRIPT ; (SP) WITH ITEM LENGTH INCL SIGN IF NEEDED FOR STRINGS ; 2(SP) HAS HEADER WORD ; 4(SP) AND 6(SP) HAVE ACCUMULATED LONG INTEGER OFFSET VALUE ; 10(SP) HAS LUN FOR VIRTUAL ARRAY ; ; EXIT TO REPEATED PART OF CODE (1$) ; (SP) AND 2(SP) WITH FLOATING ACCUMULATED OFFSET ; 4(SP) WITH LUN ; OR TO STATEMENT INTERPRETER WITH STACK CLEAN ; 2$: MOV R3,-(SP) ;SAVE DIMENSIONS MOV R4,-(SP) ; INC R3 ;ACCOUNT FOR ZEROTH ELEMENT INC R4 ; LDCIF R3,AC0 ;NOW LOAD UP FP ACCUMULATORS LDCIF R4,AC1 ;WITH DIMENSIONS (ADJUSTED FOR 0TH ELEMENTS) MULF AC1,AC0 ;GET PRODUCT -> AC0 LDCIF R2,AC1 ;ELEMENT SIZE -> AC1 MULF AC1,AC0 ;TOTAL # OF BYTES -> AC0 MOV #16,R0 ;SIZE OF VIRTUAL DATA ITEM TSTOK ;ENOUGH ROOM? BLO DIM98 ;IF NOT, BRANCH ADD R0,ENUDAT ;UPDATE END OF USER DATA MOV (SP)+,R4 ;RESTORE DIMENSIONS MOV (SP)+,R3 ; MOV (SP)+,R0 ;SIGNED ELEMENT LENGTH -> R0 MOV (SP)+,(R5)+ ;STORE HEADER WITH NAME MOV R3,(R5)+ ;SAVE 1ST SUBSCRIPT MOV R4,(R5)+ ;AND 2ND MOV 4(SP),(R5)+ ;LUN -> DATA BLOCK MOV R0,(R5)+ ;SIGNED ELEMENT LENGTH ; ; FOLLOWING CODE ROUNDS UP ACCUMULATED OFFSET IN ; ACCORD WITH RSTS BASIC+ RULES FOR VIRTUAL ARRAY ALLOCATION ; MOV R2,R4 ;ELEMENT LENGTH -> R4 MOV 2(SP),R2 ;LOWER 16 BITS -> R2 MOV #1000,R3 BIC #177000,R2 ;GET # BYTES OVER EVEN BLOCK SUB R2,R3 ;# REMAINING BYTES IN BLOCK -> R3 CLR R2 ;GET SET FOR DIVIDE DIV R4,R2 ;DIVIDE BY ELEMENT SIZE TST R3 ;CHECK REMAINDER BEQ 8$ ;IF ZERO, NO ROUND UP BIC #777,2(SP) ;CLEAR BYTE OFFSET ADD #1000,2(SP) ;GET TO START OF NEXT BLOCK ADC (SP) ;AND MAKE SURE OF DOUBLE PRECISION ADD 8$: SETL ;SET LONG INTEGER MODE LDCLF (SP)+,AC2 ;RESULT -> AC2 STCFL AC2,(R5)+ ;STORE IT AWAY IN DATA BLOCK ADDF AC0,AC2 ;NEW OFFSET -> AC2 STCFL AC2,-(SP) ;STORE IT SETI ;RESET 16 BIT INTEGER MODE ; SKIP ;DO WE HAVE CMPB R2,#', ;MORE ITEMS? BEQ 1$ ;IF SO, LOOP AROUND DEC R1 ;ELSE BACK UP TEXT PTR ADD #6,SP ;CLEAN STACK JMP INIT02 ;AND GO BACK TO STATEMENT INTERPRETER ; ; SUBROUTINE STRGLN FOR USE WITH DIM STATEMENT ; ON ENTRY: ; R1 POINTS JUST PAST '$' ; ON EXIT: ; R1 POINTS JUST PAST LEN INFO [IF THERE] ; R0 HAS LEN (+ FOR FIXED, - FOR VAR) ; 'V' SET IF SYNTAX ERROR ; OTHER REGISTERS USED: R2 ; STRGLN: SKIP ;NEXT CHAR -> R2 MOV #17,R0 ;SET DEFAULT LENGTH OF 15 DECIMAL CMPB R2,#'[ ;DO WE HAVE LENGTH? BNE 1$ ;IF NOT, BRANCH ATOI ;IF SO, GET IT -> R0 SKIP ;NEXT CHAR -> R2 CMPB R2,#'] ;IS IT CLOSE BRACKET? BNE 3$ ;IF NOT, BRANCH TO ERROR RETURN SKIP ;NEXT CHAR -> R2 1$: CMPB R2,#'V ;VARIABLE LEN STRING? BEQ 2$ ;IF SO, BRANCH DEC R1 ;IF NOT, BACK UP PTR RTS PC ;AND RETURN 2$: NEG R0 ;INDICATE VARIABLE LENGTH RTS PC ;RETURN 3$: SEV ;SET ERROR RTS PC ;RETURN ; ; SUBROUTINE SUBSUB TO RETURN SUBSCRIPT VALUES FOR DIM ; ON ENTRY: ; R1 POINTS TO START OF INFO [OPEN PAREN] ; ON EXIT: ; R1 POINTS PAST END OF SUBSCRIPT INFO [PAST CLOSE PAREN] ; R3 HAS FIRST SUBSCRIPT VALUE ; R4 HAS 2ND SUBSCRIPT VALUE (0 IF NONE SPEC'D) ; 'V' SET IF SYNTAX ERROR ; OTHER REGISTERS USED: R2,R0 ; SUBSUB: SKIP ;FIRST CHAR -> R2 CMPB R2,#'( ;START OF SUBSCRIPT? BNE 3$ ;IF NOT, BRANCH AND RETURN ZEROES ATOI ;CONVERT 1ST NUMBER MOV R0,-(SP) ;SAVE NUMBER SKIP ;NEXT CHAR -> R2 CMPB R2,#', ;ANOTHER SUBSCRIPT? BNE 1$ ;IF NOT, BRANCH ATOI ;IF SO, CONVERT IT SKIP ;GET FOLLOWING CHAR -> R2 MOV R0,R4 ;2ND VALUE -> R4 2$: MOV (SP)+,R3 ;1ST VALUE -> R3 CMPB R2,#') ;FINAL CLOSE PAREN? BNE 4$ ;IF NOT, SET ERROR RTS PC ;ELSE RETURN NICELY 1$: CLR R4 ;SET ZERO 2ND SUBSCRIPT BR 2$ ;AND FINISH UP 3$: DEC R1 ;BACK UP TEXT PTR CLR R3 ;SET ZERO CLR R4 ;SUBSCRIPTS RTS PC ;AND RETURN 4$: SEV ;SET ERROR BIT RTS PC ;AND RETURN ; ; SUBROUTINE SUBONE ; TO GET SUBSCRIPTS VIA SUBSUB AND CHECK ; THEM FOR IMMEDIATE (NON-VIRTUAL) USE. ; ON ENTRY: ; R1 = TEXT PTR ; ON EXIT: ; R1 POINTS PAST CLOSE PAREN ; R3 HAS 1ST SUBSCRIPT ; R4 HAS 2ND SUBSCRIPT ; R0 HAS PACKED SUBSCRIPTS ; 'V' SET IF ERROR ; OTHER REGISTERS USED: R2 ; SUBONE: JSR PC,SUBSUB ;GET SUBSCRIPTS BVS 1$ ;ON ERROR BRANCH MOV R4,R0 ;CHECK 2ND SUBSCRIPT DIMCHK BNE 1$ ;IF TOO BIG, ERROR MOV R3,R0 ;NOW CHECK FIRST SUBSCRIPT DIMCHK BNE 1$ ;IF TOO BIG, DECLARE ERROR SWAB R0 ;SET COMBINED SUBSCRIPTS BISB R4,R0 ;IN R0 RTS PC 1$: SEV ;INDICATE ERROR RTS PC .SBTTL DEF00 - DEFINE FUNCTION STATEMENT ;+3 ; .SKIP ; .X ^^DEF\\ ; .X ^FUNCTION - USER ; .X ^USER DEFINED FUNCTIONS ; .INDENT -5 ; ^^ ; DEF ; \\ ; .BREAK ; ^ONE LINE FUNCTION DEFINITION. ; ^THE FUNCTION NAME IS FORMED WITH THE LETTERS ^F^N FOLLOWED BY ANY ; LEGAL VARIABLE NAME. ; E.G.: ^^FNA, FNX1, FNM$\\ ETC. ; ^DUMMY ARGUMENTS MAY BE ANY NUMERIC OR STRING VARIABLE WITH ANY ; NUMBER OF ARGUMENTS SUBJECT TO FITTING ON ONE LINE. ; ^THE DEFINITION ITSELF MAY BE ANY LEGAL NUMERIC OR STRING EXPRESSION ; INCLUDING SYSTEM AND OTHER USER FUNCTIONS. ; ^FUNCTION NAMES RETURNING STRING VALUES MUST END IN '$', THOSE ; RETURNING NUMERIC VALUES MUST NOT. ; ^FUNCTIONS ARE RECURSIVE, I.E. THEY MAY USE THEMSELVES AS ARGUMENTS ; IN THE FUNCTION CALL. ; .SKIP ; ^FUNCTION DEFINITIONS CREATE AN INTERNAL POINTER TO THE ^^ASCII\\ ; TEXT TO THE RIGHT OF THE EQUAL SIGN. ; ^FOR THIS REASON THEY SHOULD BE PLACED NEAR THE BEGINNING OF THE ; PROGRAM TO AVOID BEING MOVED DURING DEBUGGING RUNS BY INSERTIONS, ; DELETIONS OR CHANGES TO LINES PRECEDING THE FUNCTION DEFINITION. ; .SKIP ; ^FUNCTION DEFINITIONS ARE DELETED BY THE ^^CHAIN\\ STATEMENT. ; .SKIP ; ^EXAMPLE: ; .NOFILL ; ^^ ; 30 DEF FNA1(A)=A^2 ; 40 DEF FNC$(X$)=X$+"ABC" ; 50 DEF FNZ3$(X$,I)=SEG$(X$,I,LEN(X$)) ; \\ ; .FILL ;- ; DEFINE STATEMENTS ARE DONE HERE - ONE TABLE ENTRY IS MADE, CONFLICTS ; ARE NOT CHECKED. REGISTERS USED - R1,R2,R4. ; DEF00: SKIP ;GET NEXT CHAR CMPB R2,#S.FN ;IS IT 'FN' TOKEN BNE DEF99 ;NO, BAD STATEMENT GETVAR ;LOOK FOR A VARIABLE NAME BVS DEF99 ;IF NONE, ERROR CMPB R2,#'$ ;IS IT STRING FCN? BNE 2$ ;IF NOT, BRANCH BIS #100000,R4 ;SET STRING FCN TYPE SKIP BR 1$ 2$: BIS #060000,R4 ;SET NUM FCN TYPE 1$: CLR R0 ;IS FCN DEFINED ALREADY MOV STUDAT,R3 SRLST BNE DEF99 ;SUCCESS IS FAILURE MOV ENUDAT,R5 MOV R4,R0 ;PUSH HEADER ON STACK PUSH CMP R2,#'( ;IS THE REQUIRED LEFT PAREN PRESENT? BNE DEF99 ;NO MOV R5,R3 ;SAVE ADDRESS FOR NUM OF PARAMS CLR R0 PUSH PUSH ;SPACE FOR PAST = ADDRESS CMPB R2,#'( ;DO WE HAVE PARAMS BNE DEF99 ;IF NOT, ERROR 5$: GETVAR ;GET DUMMY NAME BVS DEF99 ;IF BAD, ERROR CMPB R2,#'$ ;IS IT STRING? BNE 3$ ;IF YES, BIS #120000,R4 ;SET STRING TYPE SKIP 3$: MOV R4,R0 ;PUT IT IN USER AREA PUSH INC (R3) ;COUNT IT CMPB R2,#') ;ARE WE AT END OF PARAMS BEQ 4$ ;IF SO, BRANCH OUT OF LOOP CMPB R2,#', ;COMMA SEPARATOR? BEQ 5$ ;IF SO, GET NEXT PARAM BR DEF99 ;ELSE ERROR 4$: SKIP CMPB R2,#'= ;IS NEXT CHAR '=' BNE DEF99 ;ERROR IF NOT MOV R1,2(R3) ;PUT ADDRESS IN ITS PLACE SUB USR,2(R3) ;MAKE IT INTO OFFSET FROM START OF PROGRAM MOV R5,ENUDAT ;MAKE FCN ITEM PERMANENT JUNKIT ;SKIP REST OF DEFINITION MOVB (R1)+,R2 ;TERMINATOR -> R2 (EVEN S.EOL1) JMP INIT03 ;AND PROCEED DEF99: DEFERR ;HORRIBLE ERROR!!! .SBTTL EVAL00 - EVALUATE AN ARITHMETIC EXPRESSION ; ; EVAL - EVAL00, EVALUATE AN ARITHMETIC EXPRESSION. UPON ENTRY, R1 ; POINTS TO THE CURRENT TEXT POSITION. ON EXIT AC0 CONTAINS ; THE NUMERIC VALUE OF THE EXPRESSION. REGISTERS USED - ALL. ; V-BIT WILL BE SET IF EXPRESSION TERMINATED BY ')', CLEAR OTHERWISE. ; ON V SET, R1 POINTS PAST CLOSE PAREN ; ON V CLEAR, R1 POINTS TO TERMINATING CHAR ; EVAL00: CLR R0 TSTOK ;CHECK FOR BACKUP ROOM BLO EVAL18 ;ON ERROR, BRANCH PUSH ;CLEAR THE PAREN COUNT MOV #-1,-(SP) ;PUSH NULL (-1) ON STACK EVAL02: SKIP ;GET A NON-BLANK CHARACTER CMP R2,#'+ ;IS THIS A UNARY PLUS? BEQ EVAL03 ;YES, IGNORE IT CMP R2,#'- ;IS IT A UNARY MINUS? BNE EVAL01 ;NO MOV R2,R0 ;YES, SET OPERAND2=0 CLRF AC0 ;AND PUT THE OPERATOR IN R0 BR EVAL05 EVAL03: SKIP ;GET ACHARACTER EVAL01: CMP R2,#'( ;IS OPERAND AN OPEN PAREN? BNE EVAL04 ;NO, GET A REAL OPERAND CLR -(SP) ;PUSH A NULL ON THE STACK INC -2(R5) ;INCREMENT THE PAREN COUNT BR EVAL02 ;GO BACK AND DO IT AGAIN EVAL05: STF AC0,-(SP) ;PUSH OPERAND ON THE STACK MOV R0,-(SP) ; OPERATOR ON STACK BR EVAL03 ;AND GO BACK AROUND EVAL04: DEC R1 ;MOVE CHARACTER POINTER BACK ONE MOV -(R5),-(SP) ;SAVE PAREN COUNT JSR PC,GTP00 ;GET AN OPERAND MOV ENUDAT,R5 ;RESTORE R5 MOV (SP)+,(R5)+ ;RESTORE THE PAREN COUNT EVAL12: MOV R2,-(SP) ;SAVE R2 SKIP ;GET A CHARACTER MOV #EVAL07+7,R0 ;GET ADDRESS OF LIST GTPR01: CMPB -(R0),R2 ;IS IT A LEGAL OPERATOR? BEQ GTPR02 ;JUMP IF LEGAL CMP R0,#EVAL07+1 ;HAS SEARCH FAILED? BHI GTPR01 ;NO CLR R0 ;YES - SET ZERO AND BACK UP POINTER DEC R1 ; TO POINT AT FAILURE GTPR03: MOV (SP)+,R2 ;RESTORE R2 BR EVAL19 ;AND CONTINUE GTPR02: MOV R2,R0 ;PUT A CHARACTER IN R0 BR GTPR03 EVAL19: TST @SP ;IS STACK NULL? BLE EVAL17 EVAL06: MOV R1,-(SP) ;SAVE THE TEXT POINTER MOV #EVAL07+7,R1 ;GET THE TABLE ADDRESS EVAL08: CMPB -(R1),R0 ;FIND OPERATOR2 BNE EVAL08 ;IT MUST BE FOUND ASR R1 ;GET RID OF THE BYTE POINTER MOV R1,(R5)+ ;PUT RESULT ON USER LIST FOR A WHILE MOV #EVAL07+7,R1 ;GET TABLE ADDRESS AGAIN EVAL09: CMPB -(R1),2(SP) ;FIND OPERATOR1 BNE EVAL09 ;IT MUST BE THERE ASR R1 ;CLEAR LOW ORDER BIT MOV R1,(R5)+ ;SAVE IT FOR NOW MOV (SP)+,R1 ;RESTORE TEXT POINTER CMP -(R5),-(R5) ;COMPARE OPERATOR1 WITH OPERATOR2 BLT EVAL05 ;GO BACK IF PRECEDENCE IS WRONG MOV R0,(R5)+ ;SAVE OPERATOR2 FOR NOW MOV #EVAL07+7,R0 EVAL10: CMPB -(R0),@SP ;FIND APPROPRIATE OPERATOR IN LIST BNE EVAL10 ;IT MUST BE FOUND SUB #EVAL07+2,R0 ;GET DISPLACEMENT ASL R0 ASL R0 ADD #EVAL11,R0 ;WE NOW HAVE THE ROUTINE ADDRESS MOV R0,(R5)+ ;SAVE IT TST (SP)+ ;DISCARD OLD OPERATOR1 LDF AC0,AC1 ;PUT SOURCE IN AC1 LDF (SP)+,AC0 ;AND DEST IN AC0 MOV -(R5),R2 ;ROUTINE ADDRESS JSR PC,(R2) ;GO COMPUTE VALUE MOV -(R5),R0 ;RESTORE OPERATOR2 TST @SP ;IS STACK NULL? BGT EVAL06 ;NO, TAKE CARE OF REST OF STACK EVAL17: CMP R0,#') ;IS OPERATOR2 A CLOSED PAREN? BEQ EVAL14 ;YES TST R0 ;NO, IS IT NULL? BGT EVAL05 ;NOT NULL - GO BACK TST -(R5) ;IS THE PAREN COUNT ZERO? BNE EVAL13 ;NO TST (SP)+ ;POP NULL CCC RTS PC ;RETURN WITH RESULT IN R2,R3,R4. EVAL13: PARERR ;PAREN COUNT BAD EVAL14: TST -(R5) ;IS PAREN COUNT ZERO? BNE EVAL15 ;NO EVAL16: TST (SP)+ ;POP NULL SEV ;YES, ERROR - BUT DON'T TELL USER YET RTS PC EVAL15: TST @SP ;JUMP BLT EVAL16 ;IF NULL = -1 TST (SP)+ ;POP NULL DEC (R5)+ ;DECREMENT PAREN COUNT BR EVAL12 ;AND DO IT AGAIN EVAL18: OVFERR EVAL07: .BYTE 0,') ;DO NOT .BYTE '+,'- ; CHANGE .BYTE '*,'/ ; THE ORDER .BYTE '^ ; OF THIS TABLE .EVEN ; END OF TABLE REFERENCED AT: EVAL06+2, EVAL08+8, EVAL10-2 ; ARGUMENTS ARE FIRST IN AC0, SECOND IN AC1 EVAL11: ADDF AC1,AC0 ;DO AN ADD RTS PC SUBF AC1,AC0 ;DO A SUBTRACT RTS PC MULF AC1,AC0 ;DO A MULTIPLY RTS PC DIVF AC1,AC0 ;DO A DIVIDE RTS PC JMP PWRF00 ;POWER IS EXTERNAL TO HERE .SBTTL GTP00 - GET AN OPERAND ; ; GETOP - GTP00, GET AN OPERAND. ; ON ENTRY: ; R1 POINTS TO START OF OPERAND ; ; ON EXIT: ; R1 POINTS TO NEXT CHAR AFTER SCAN ENDED ; AC0 HAS VALUE OF OPERAND ; ; OTHER REGISTERS USED: POTENTIALLY ALL ; ; NOTE: THIS ROUTINE MUST BE RE-ENTRANT SINCE IT MAY RE-ENTER ITSELF ; VIA CALLS TO "EVAL". ; GTP00: MOV R1,-(SP) ;SAVE TEXT BACKUP POINTER SKIP ;GET FIRST CHARACTER BIC #177400,R2 ;CLEAR SIGN EXTEND CMPB R2,#S.SAST ;IN FCN RANGE? BLO 3$ ;IF BELOW, TRY FOR SOMETHING ELSE CMPB R2,#S.SAEN ;PAST END OF SINGLE ARG FCNS? BHI 1$ ;IF SO, TRY FOR OTHER FUNCTION TYPE SUB #140,R2 ;CALCULATE TABLE ASL R2 ;OFFSET MOV R2,-(SP) ;AND SAVE IT EVAL ;ARG VALUE -> AC0 BVC 21$ ;IF NO CLOSE PAREN, ERROR MOV (SP)+,R2 ;RESTORE TABLE OFFSET TST (SP)+ ;REMOVE BACKUP TEXT POINTER JSR PC,@INIT12(R2) ;GO TO THE ROUTINE RTS PC 1$: CMPB R2,#S.NFBO ;PAST END NUMERIC FCNS? BHI 2$ ;IF SO, ERROR SUB #140,R2 ;CALCULATE TABLE ASL R2 ;OFFSET MOV ENUDAT,(SP) ;COVER TEXT PTR WITH EOD PTR CLR -(SP) ;SLOT FOR TEXT PTR JSR PC,@INIT12(R2) ;GO TO ROUTINE MOV (SP)+,R1 ;GET PROPER END OF TEXT PTR MOV (SP)+,ENUDAT ;AND END OF USER DATA RTS PC 2$: CMPB R2,#S.FN ;USER FCN? BEQ 7$ ;IF SO, GO DO IT BNE 6$ ;IF NOT, ERROR 3$: TSTCH BVS 15$ ;JUMP IF BAD OPERAND BNE 9$ ;JUMP IF NOT NUMERIC 18$: MOV (SP)+,R1 ;RESTORE CHARACTER POINTER ATOF ;CONVERT THE NUMBER, IGNORING ERROR FLAGS BVS 6$ RTS PC 15$: CMP R2,#'. ;DOES THE NUMBER START WITH "."? BEQ 18$ ;YES BR 6$ ;NO 7$: GETVAR ;GET FOLLOWING VARIABLE NAME BVS 6$ ;ERROR IF NO VARIABLE NAME AFTER "FN" MOV STUDAT,R3 ;GET ADDRESS OF USER STORAGE CLR R0 ;SET ZERO MASK FOR THE SEARCH BIS #060000,R4 ;SET CLASS 3 SRLST ;SEARCH THE LIST FOR THE ITEM BEQ 6$ ;GO REPORT ERROR IF NOT DEFINED JSR PC,FNSET ;GO SET UP PARAMS MOV R1,-(SP) ;SAVE TEXT POINTER MOV R0,R1 ;PUT DEF ADDRESS IN R1 EVAL BVC 20$ ;NO ')' ALLOWED 21$: PARERR ;ERROR IF NOT 6$: ILFERR 20$: SKIP ;NEXT CHAR IN FCN DEF -> R2 CMPB R2,#S.EOS1 ;AT END OF STATEMENT? BLO 6$ ;IF NOT, ERROR MOV (SP)+,R1 ;RESTORE R1 JSR PC,FNCLR ;CLEAN UP MESS WE'VE MADE TST (SP)+ ;CLEAR BACKUP TEXT POINTER RTS PC 9$: MOV (SP)+,R1 ;IT'S A VARIABLE, RESTORE POINTER JSR PC,GETHDR ;GET HEADER ADDRESS OF VARIABLE BEQ 2$ ;IF NOT DEFINED, BRANCH TO ERROR JMP @11$(R0) ;GO TO APPROPRIATE ROUTINE 11$: .WORD 13$ ;REAL*4 .WORD 13$ ;INTEGER .WORD 13$ ;BYTE .WORD 12$ ;REAL*8 12$: NXVERR ;NON-EXISTENT VARIABLE CLRF AC0 ;ZERO RESULT PASSED BACK RTS PC 13$: JSR PC,GTOFFS ;GET THE OFFSET JSR PC,GETNUM ;AND THE NUMBER RTS PC .SBTTL LEN00 - LENGTH OF STRING FUNCTION .SBTTL FNSET - PARAM SETUP FOR USER FCN ; ; FNSET - SET UP PARAMS FOR FUNCTION CALL ; RETURN ADDRESS IS PULLED FROM STACK AND STACK IS USED ; TO STORE INFO ON ALREADY DEFINED DUMMY PARAMS. ENTRIES ; FOR DUMMY PARAMS ARE PUT INTO USER AREA AND NAMES FOR ; PREVIOUSLY DEFINED DUMMY PARAMS ARE ZEROED. ; ON CALL: ; R3 POINTS TO FCN ENTRY ; R1 POINTS TO FIRST ACTUAL ARG IN LIST ; ON EXIT: ; R1 POINTS PAST CLOSING ')' ; R0 POINTS PAST = SIGN FOR FCN DEF ; FNSET: MOV (SP)+,R2 ;POP RETURN ADDRESS MOV ENUDAT,-(SP) ;SAVE ENUDAT CLR -(SP) ;SET BOUNDARY FOR ARG INFO MOV R2,-(SP) ;PUT BACK RETURN ADDRESS TST (R3)+ ;PUSH PAST HEADER MOV (R3)+,R0 ;COUNT IN R0 MOV (R3)+,R2 ;ADDRESS OF PAST = SIGN IN R2 6$: MOV (R3)+,R4 ;NEXT DUMMY ARG IN R4 LDCIF R2,AC1 ;SAVE A FEW REGISTERS FOR A WHILE LDCIF R3,AC2 LDCIF R0,AC3 MOV STUDAT,R3 CLR R0 SRLST ;IS DUMMY DEFINED? BEQ 1$ ;IF NOT FOUND, THINGS ARE EASY MOV (SP)+,R2 ;RETURN ADDRESS IN R2 MOV (R3),-(SP) ;SAVE HEADER MOV R3,-(SP) ;AND ITS ADDRESS MOV R2,-(SP) ;PUT BACK RETURN ADDRESS 1$: STCFI AC1,-(SP) ;SAVE REGISTERS (R2) STCFI AC2,-(SP) ;FOR REENTRANCE (R3) STCFI AC3,-(SP) ; (R0) MOV R4,-(SP) ;SAVE PARAM NAME BIT #020000,R4 ;STRING PARAM? BNE 2$ ;IF SO, BRANCH EVAL ;EVALUATE ACTUAL PARAM BVC 10$ ;BACK UP IF CLOSE PAREN DEC R1 10$: SKIP MOV #10,R0 ;CHECK FOR ROOM TSTOK BLO 14$ ;IF NO ROOM, BRANCH MOV (SP)+,(R5)+ ;PUT AWAY NAME CLR (R5)+ ;ZERO DIMENSIONS STF AC0,(R5)+ ;STORE VALUE MOV R5,ENUDAT ;MAKE IT SEMI-PERMANENT BR 4$ 2$: MOV #10,R0 ;MAKE ROOM FOR STRING HEADER INFO TSTOK BHIS 9$ 14$: OVFERR 9$: MOV #160006,(R5) ;SAFEGUARD THESE FOUR WORDS ADD R0,R5 MOV ENUDAT,-(SP) ;SAVE OLD END OF USER LIST MOV R5,ENUDAT ;CREATE NEW END EVALS ;GET STRING, ADD -> R3, LEN -> R4 BVS 7$ ;REPORT ERROR MOV (SP)+,R5 ;RESTORE OLD R5 MOV (SP)+,(R5)+ ;PUSH NAME CLR (R5)+ ;ZERO DIMENSIONS MOV R4,(R5)+ ;AND LEN ALONG WITH FIXED TYPE MOVB R4,(R5)+ ;ACTUAL LEN BEQ 13$ 3$: MOVB (R3)+,(R5)+ ;AND STRING ITSELF SOB R4,3$ 13$: INC R5 ;ROUND R5 UP TO EVEN BIC #1,R5 ;BOUNDARY MOV R5,ENUDAT SKIP ;GET NEXT CHAR IN R2 (NOT DONE BY EVALS) 4$: MOV (SP)+,R0 ;RESTORE COUNT OF ARGS MOV (SP)+,R3 ;AND ARG ADDRESS CMPB #'),R2 ;AT END OF ACTUAL PARAMS? BEQ 8$ ;IF SO, BRANCH CMPB #',,R2 ;IS IT COMMA BEQ 5$ ;IT BETTER BE 7$: ILFERR 5$: MOV (SP)+,R2 ;ADD OF PAST = SIGN IN R2 DEC R0 ;DEC AND DO IT AGAIN BEQ 7$ ;SHOULD NEVER GET TO ZERO JMP 6$ 8$: DEC R0 ;IF COUNT WAS 1, OK BNE 7$ ;ANYTHING ELSE = BAD NEWS MOV (SP)+,R0 ;ADD OF PAST = SIGN IN R0 ADD USR,R0 ;MAKE INTO REAL ADDRESS MOV SP,R2 ;GET ADDRESS OF LIST OF TST (R2)+ ;BLANKED PARAMS 11$: MOV (R2)+,R3 ;ADDRESS OF PARAM BEQ 12$ ;ZERO MEANS END OF LIST BIC #7777,(R3) ;CLEAR OUT NAME TST (R2)+ ;SKIP OVER OLD NAME BR 11$ ;DO ALL OF THEM 12$: RTS PC ;RETURN WITH SAVED INFO ON STACK ; ; SUBROUTINE TO RESET DATA ITEMS AFTER ; FUNCTION EVALUATION. ; REGISTERS USED: R2,R0 ; FNCLR: MOV (SP)+,R0 ;SAVE RETURN ADD 1$: MOV (SP)+,R3 ;ADD OF DATA ITEM BEQ 2$ ;BR IF AT END MOV (SP)+,(R3) ;RESTORE OLD NAME BR 1$ 2$: MOV (SP)+,ENUDAT ;GET US BACK TO WHERE WE WERE MOV R0,-(SP) ;PUT BACK RETURN ADD RTS PC .SBTTL EVLS00 - EVALUATE A STRING EXPRESSION ; ; EVALS, EVLS00 - EVALUATE A STRING EXPRESSION OF THE FORM: ; STRE1 + [STRE2 + ...] ; WHERE: ; STRE1 AND STRE2 ARE STRING ELEMENTS ; A STRING ELEMENT MAY BE: ; A STRING CONSTANT (IN DOUBLE QUOTES) ; A STRING VARIABLE (ENDING IN '$') ; A STRING FUNCTION (SYSTEM OR USER DEFINED) ; ON ENTRY: ; R1 POINTS TO START OF PROGRAM TEXT WITH STRING EXPRESSION ; ; ON EXIT: ; R1 POINTS TO FIRST CHAR PAST END OF EXPRESSION ; R3 HAS ADDRESS (IN FREE SPACE) ; R4 HAS LEN ; 'V' SET FOR BAD STRING EXPRESSION AND R1 AS ON ENTRY ; EVLS00: MOV #2,R0 ;CHECK FOR HEADER ROOM ONLY TSTOK ;(ENUDAT -> R5) BLO 18$ ;IF NOT ENOUGH ROOM, BRANCH MOV R5,-(SP) ;SAVE HEADER ADDRESS (AND ORIGINAL ENUDAT) MOV #160000,(R5)+ ;SET UP HEADER WITH NO LENGTH MOV R1,-(SP) ;SAVE TEXT PTR 3$: MOV R5,-(SP) ;SAVE CURRENT POSITION OF R5 (END OF ;ACCUMULATED STRING) INC R5 ;ROUND IT UP BIC #1,R5 MOV R5,ENUDAT ;AND PROTECT WHAT WE ALREADY HAVE JSR PC,GSTR00 ;GET STRING ELEMENT (WHICH MAY IN ;TURN EVALUATE A STRING) BVS 4$ ;IF ERROR, BRANCH BLE 2$ ;IF ZERO OR LESS, BRANCH MOV R4,R0 ;LEN OF OPERAND -> R0 MOV R3,-(SP) ;SAVE ADDRESS TSTOK ;CHECK FOR ROOM BLO 18$ ;IF NOT ENOUGH, BRANCH MOV (SP)+,R3 ;RESTORE STRING ELEMENT ADDRESS MOV (SP)+,R5 ;AND CURRENT END OF STRING MOV @2(SP),R2 ;HEADER -> R2 BIC #160000,R2 ;CLEAR DATA TYPE ADD R0,R2 ;ADD IN NEW LEN BIT #160000,R2 ;IS IT TOO BIG? BNE 18$ ;IF SO, BRANCH BIS #160000,R2 ;SET HEADER TYPE MOV R2,@2(SP) ;AND STORE IT AWAY 1$: MOVB (R3)+,(R5)+ ;MOVE IN NEW ELEMENT SOB R0,1$ MOV R5,-(SP) ;JUST TO KEEP STACK STRAIGHT 2$: MOV (SP)+,R5 ;RESTORE R5 (END OF ACCUM STRING) SKIP ;NEXT TEXT CHAR CMPB R2,#'+ ;MORE ELEMENTS? BEQ 3$ ;IF SO, GO ADD THEM DEC R1 ;ELSE BACK UP TST (SP)+ ;POP OLD R1 MOV (SP)+,R3 ;ADDRESS OF HEADER -> R3 MOV R3,ENUDAT ;ALSO RESTORE ORIGINAL END OF DATA MOV (R3)+,R4 ;HEADER -> R4, R3 AT STRING START BIC #160000,R4 ;CLEAR HEADER TYPE, LEAVING LENGTH CCC ;SET SUCCESS RTS PC 4$: TST (SP)+ ;POP END OF ACCUM STRING MOV (SP)+,R1 ;RESTORE R1 AS WE ENTERED MOV (SP)+,ENUDAT ;AND END OF USER DATA CLR R4 ;ZERO LEN SEV ;NO EXPRESSION RTS PC 18$: OVFERR .SBTTL GSTR00 - GET A STRING OPERAND ; ; GSTR, GSTR00 - GET A STRING OPERAND ; ; AT END OF SUCCESSFUL COMPLETION OF THIS ROUTINE, ; R3 CONTAINS AN INDIVIDUAL STRING ADDRESS AND R4 ; CONTAINS ITS LENGTH ; GSTR00: SKIP ;GET NEXT TEXT CHAR BIC #177400,R2 ;CLEAR OUT SIGN EXTEND CMPB R2,#S.SFST ;ARE WE IN RANGE OF STRING FUNCTION TOKENS? BLO 1$ ;IF NOT, TRY SOMETHING ELSE CMPB R2,#S.SFEN ;OVER THE TOP? BHI 2$ ;IF SO, GO LOOK FOR USER FUNCTION SUB #140,R2 ;MAKE R2 INTO JUMP TABLE OFFSET ASL R2 JSR PC,@INIT12(R2) ;GO TO FUNCTION TST R4 ;SET LENGTH CONDITION CODES RTS PC ;AND GO BACK WHER WE CAME FROM 2$: CMPB R2,#S.FN ;USER FUNCTION DEFINITION? BEQ GSTR01 ;IF SO, GO TO THAT CODE BR GSTR09 ;IF NOT, ERROR 1$: TSTCH ;WHAT IS IT BVS GSTR10 ;NOT ALPHANUM MAYBE " BEQ GSTR09 ;NUMBER=ERROR GSTR06: DEC R1 ;RESTORE TEXT POINTER JSR PC,GETHDR ;GET HEADER ADDRESS BVS GSTR09 ;NON-EXIST VAR BEQ GSTR09 ;DITTO CMP #10,R0 ;IS THIS A STRING? BNE GSTR09 ;IF NOT, REPORT ERROR JSR PC,GTOFFS ;GET THE OFFSET MOV R3,R0 ;HEADER ADDRESS -> R0 JSR PC,GETSTR ;AND THE STRING ITSELF GSTR02: TST R4 ;SET CONDITION CODES ON LENGTH RTS PC ;BACK TO CALLER GSTR09: SEV RTS PC ;AND RETURN GSTR10: CMP R2,#'" ;THIS A STRING CONSTANT BNE GSTR09 ;ERR IF NOT MOV R1,R3 ;SAVE STRING START ADDRESS CLR R4 ;REGISTER FOR LENGTH GSTR11: CMPB (R1)+,#'" ;END OF STRING BEQ GSTR02 ;RETURN IF SO CMPB -(R1),#S.EOL1 ;END OF LINE? BHIS 1$ ;RETURN IF SO TOO INC R1 ;SKIP OVER CHAR INC R4 ;ADD TO LENGTH BR GSTR11 ;LOOP TILL END FOUND 1$: UNMERR ;UNMATCHED QUOTES ERROR ; ; ADDED CODE TO HANDLE USER STRING FUNCTIONS ; GSTR01: GETVAR ;NAME OF STRING FCN IN R4 BVS GSTR09 ;IF UNSUCCESSFUL, ERROR CMPB R2,#'$ ;IS IT STRING FCN NAME? BNE GSTR09 ;IF NOT, ERROR SKIP CMPB R2,#'( ;MUST HAVE ARG LIST BNE GSTR09 ;ELSE ERROR MOV STUDAT,R3 CLR R0 ;NO MASK BIS #100000,R4 ;SET STRING FCN TYPE SRLST BEQ GSTR09 ;IF NOT FOUND, ERROR JSR PC,FNSET ;SET UP PARAMS MOV R1,-(SP) ;SAVE R1 MOV R0,R1 ;TEMP R1 FOR FCN EVAL EVALS BVC 1$ ;IF OK, SKIP ILFERR ;OTHERWISE ERROR! 1$: SKIP CMPB R2,#') ;NO EXTRA PARENS ALLOWED BNE 2$ PARERR 2$: MOV (SP)+,R1 ;RESTORE TEXT POINTER MOV R3,R2 ;SAVE STRING ADDRESS JSR PC,FNCLR ;CLEAN UP MESS MOV R2,R3 ;RESTORE ADDRESS TST R4 ;SET CON CODES RTS PC .SBTTL GETHDR - GET ADDRESS OF DATA ELEMENT HEADER ; ; ON ENTRY: ; R1 IS TEXT PTR WHICH SHOULD POINT TO VAR NAME START ; ; ON EXIT: ; R1 POINTS TO CHAR FOLLOWING VAR NAME ; R3 HAS HEADER ADDRESS ; R0 HAS RETURN CODE (FOR USE AS JUMP INDEX) ; 0 = SINGLE PRECISION FLOATING ; 2 = INTEGER ; 4 = BYTE ; 6 = DOUBLE PRECISION ; 10= STRING VARIABLE ; R4 HAS HEADER TYPE AND VAR NAME ; 'Z' SET IF VAR NOT DEFINED, CLEAR OTHERWISE ; IN THIS CASE R3 IS NOT DEFINED ; 'V' SET IF NO VAR IN TEXT (SYNTAX ERROR) ; IN THIS CASE R4, R3 AND R0 ARE NOT DEFINED ; ; NOTE: ON RETURN, 'V'-BIT SHOULD BE TESTED FIRST AND THEN 'Z' BIT ; GETHDR: CLR R0 ;CLEAR R0 FOR SEARCH MASK MOV R0,-(SP) ;AND SET ERROR RETURN CODE GETVAR ;2 CHAR VAR NAME -> R4 (3RD CHAR -> R2) BVS 11$ ;ON ERROR, BRANCH CMPB R2,#'$ ;DO WE HAVE STRING TYPE? BEQ 1$ ;IF SO, BRANCH CMP R2,#'% ;INTEGER TYPE? BEQ 2$ ;IF SO, BRANCH TO INTEGER CODE CMPB R2,#'& ;BYTE TYPE SPEC'D? BEQ 3$ ;IF SO, BRANCH ; ; OTHER VARIABLE TYPE DETERMINATIONS TO BE DONE HERE ; DEC R1 ;BACK UP TEXT PTR IF ORDINARY FLOATING VAR ;STACK LEFT AT 0 FOR FLOATING VAR. BR 10$ ;BRANCH TO COMMON FINISH 1$: BIS #120000,R4 ;SET STRING TYPE IN HEADER MOV #10,(SP) ;SET STRING RETURN CODE BR 10$ ;BRANCH TO COMMON FINISH 2$: BIS #20000,R4 ;SET INTEGER HEADER MOV #2,(SP) ;SET INTEGER TYPE ON STACK BR 10$ 3$: BIS #40000,R4 ;SET BYTE HEADER MOV #4,(SP) ;AND TYPE ON STACK BR 10$ ; ; CODE FOR OTHER VARIABLE TYPES TO BE INSERTED HERE ; 10$: MOV STUDAT,R3 ;SET UP FOR SEARCH SRLST ;SEE IF IT'S THERE BEQ 12$ ;IF NOT THERE, BRANCH 11$: MOV (SP)+,R0 ;SET RETURN CODE CLZ ;INDICATE VAR FOUND RTS PC 12$: MOV (SP)+,R0 ;POP TYPE RETURN CODE SEZ ;INDICATE NO VAR DEFINED RTS PC .SBTTL GTOFFS - GET OFFSET OF ACTUAL DATA ; ; ON ENTRY: ; R3 POINTS TO DATA ITEM HEADER ; R1 POINTS TO TEXT FOLLOWING VAR NAME (OPEN PAREN IF THERE) ; ; ON EXIT: ; R3 AS ABOVE ; R1 POINTS PAST CLOSE PAREN (IF SUBSCRIPT USED) ; AC0 HAS: ; 1) FOR STANDARD VAR, OFFSET FROM STUDAT ; (R0 HAS ABSOLUTE ADDRESS IN THIS CASE) ; 2) FOR VIRTUAL ARRAY, OFFSET FROM FILE START (IN BYTES) ; ; OTHER REGISTERS USED: R2, R0, R4, AC1, AC2 ; GTOFFS: BIT #10000,(R3) ;VIRTUAL ARRAY? BNE 3$ ;IF SO, BRANCH MOV R3,-(SP) ;SAVE R3 MOV (R3)+,R0 ;HEADER -> R0 ASH #-14,R0 ;SHIFT BITS DOWN BIC #177761,R0 ;CLEAR ALL BUT ITEM TYPE MOV R0,-(SP) ;AND SAVE TYPE ON STACK SKIP CMPB R2,#'( ;SUBSCRIPT? BNE 1$ ;IF NOT, SIMPLE VARIABLE CMP R0,#12 ;DO WE HAVE STRING? BNE 6$ ;IF NOT, BRANCH CLR R0 ;GET SET TO GET STRING LENGTH BISB 2(R3),R0 ;WITHOUT SIGN EXTEND INC R0 ;AND ADD LENGTH BYTE MOV R0,-(SP) ;SAVE IT ON STACK BR 7$ 6$: MOV 5$(R0),-(SP) ;LEN OF NUMERIC ELEMENT ON STACK 7$: MOV R3,-(SP) ;SAVE CURRENT POSITION OF R3 EVAL ;GET 1ST SUBSCRIPT BVS 8$ ;IF CLOSE PAREN, BRANCH STCFI AC0,-(SP) ;STORE FIRST SUBSCRIPT SKIP ;GET NEXT TEXT CHAR CMPB R2,#', ;MUST BE COMMA BNE 98$ ;ELSE ERROR EVAL ;GET 2ND SUBSCRIPT BVC 98$ ;MUST END WITH CLOSE PAREN STCFI AC0,R0 ;2ND SUBSCRIPT -> R0 BR 9$ 8$: STCFI AC0,-(SP) ;1ST (AND ONLY) SUBSCRIPT ON STACK CLR R0 ;2ND IS IMPLIED 0 9$: MOV 2(SP),R3 ;RESTORE R3 CLR R2 ;MAKE SURE R2 CLEAR SO WE CAN GET BISB (R3)+,R2 ;2ND SUBSCRIPT LIMIT -> R2 CMP R0,R2 ;COMPARE ACTUAL TO MAX BHI 99$ ;IF TOO BIG, ERROR CLR R2 ;GET SET TO GET UNSIGNED BISB (R3)+,R2 ;1ST SUBSCRIPT LIMIT -> R2 CMP (SP),R2 ;COMPARE 1ST SUBSCRIPT TO MAX BHI 99$ ;IF TOO BIG, ERROR MOV R3,2(SP) ;RE-SAVE R3 CLR R2 ;GET Y.MAX -> R2 BISB -2(R3),R2 ;IN UNSIGNED WAY MOV R2,R3 ;NOW DO WORK IN R3 INC R3 ;ADD ONE FOR ZEROTH ELEMENT MUL (SP)+,R3 ;X*(Y.MAX+1) -> R3 ADD R0,R3 ;Y+X*(Y.MAX+1) -> R3 MOV (SP)+,R2 ;R2 NOW HAS PTR TO START OF DATA ELEMENTS MUL (SP)+,R3 ;MULTIPLY BY ELEMENT LENGTH ADD R2,R3 ;ADD IN OFFSET 10$: CMP (SP)+,#12 ;DO WE HAVE STRING? BNE 2$ ;IF NOT, BRANCH ADD #3,R3 ;ELSE ADD EXTRA WORD PLUS LEADING LEN BYTE 2$: MOV R3,R4 ;COPY -> R4 MOV R3,R0 ;AND -> R0 MOV (SP)+,R3 ;HEADER ADDRESS SUB STUDAT,R4 ;OFFSET -> R4 LDCIF R4,AC0 ;NOW -> AC0 RTS PC 1$: DEC R1 ;BACK UP TEXT PTR TST (R3)+ ;PUSH TO 3RD WORD BR 10$ ;AND GO FINISH 98$: SBSERR ;BADLY FORMED SUBSCRIPT 99$: SUBERR ;SUBSCRIPT OUT OF RANGE 5$: .WORD 4 ;REAL*4 (NORMAL TYPE) .WORD 2 ;INTEGER*2 .WORD 1 ;BYTE .WORD 10 ;REAL*8 ; ; VIRTUAL SECTION ; 3$: JSR PC,VSUBSC ;GET ELEMENT NUMBER (LINEAR) -> AC0 LDCIF 10(R3),AC1 ;ELEMENT SIZE -> AC1 ABSF AC1 ;MAKE SURE POSITIVE MULF AC1,AC0 ;GET TOTAL BYTE OFFSET IN ARRAY SETL ;LONG INTEGER MODE LDCLF 12(R3),AC2 ;START OFFSET FOR ARRAY -> AC2 ADDF AC2,AC0 ;ADD IT IN FOR FILE OFFSET SETI ;BACK TO 16 BIT INTEGERS RTS PC ;AND RETURN ; ; VIRTUAL SUBSCRIPT CALCULATION ; VSUBSC: SKIP ;NEXT CHAR -> R2 CMPB R2,#'( ;CHECK FOR SUBSCRIPT BNE 3$ ;IF NONE, (0,0) ELEMENT ASSUMED MOV R3,-(SP) ;SAVE DATA ITEM PTR EVAL ;FIRST SUBSCRIPT -> AC0 BVS 1$ ;IF CLOSE PAREN, SHORT CALC. STF AC0,-(SP) ;STORE IT ON STACK SKIP ;CHECK NEXT CHAR. CMPB R2,#', ;FOR COMMA BNE 4$ ;IF NO COMMA, BADLY FORMED SUBSCRIPT EVAL ;GET 2ND SUBSCRIPT BVC 4$ ;IF NO CLOSE PAREN, BADLY FORMED SUBSCRIPT LDF (SP)+,AC1 ;1ST SUBSCRIPT -> AC1 2$: MOV (SP)+,R3 ;RESTORE PTR TO VIRTUAL DATA ITEM STCFI AC0,R0 ;INTEGERIZE 2ND SUBSCRIPT CMP R0,4(R3) ;CHECK ITS RANGE BHI 5$ ;IF TOO HIGH, RANGE ERROR LDCIF R0,AC0 ;RE-LOAD 2ND SUBSCRIPT INTEGERIZED STCFI AC1,R0 ;GET 1ST SUBSCRIPT CMP R0,2(R3) ;CHECK ITS RANGE BHI 5$ ;IF TOO HIGH, RANGE ERROR LDCIF R0,AC1 ;1ST SUBSCRIPT -> AC1 (INTEGERIZED) LDCIF 4(R3),AC2 ;SIZE OF 2ND DIMENSION ADDF #1,AC2 ;PLUS ONE -> AC2 MULF AC2,AC1 ;TIMES FIRST SUBSCRIPT ADDF AC1,AC0 ;ADDED TO 2ND FOR RESULT RTS PC ;AND RETURN 1$: LDF AC0,AC1 ;MAKE SURE 1ST SUBSCRIPT -> AC1 CLRF AC0 ;2ND SUBSCRIPT = IMPLIED 0 BR 2$ ;GO FINISH IN REGULAR WAY 3$: DEC R1 ;BACK UP TEXT PTR CLRF AC0 ;ZEROTH ELEMENT WANTED RTS PC ;AND RETURN 4$: SBSERR ;BADLY FORMED SUBSCRIPT 5$: SUBERR ;SUBSCRIPT OUT OF RANGE ; ; SUBROUTINE VIRACC ; TO GET NEEDED DISK BLOCK IN MEMORY GIVEN AN ; OFFSET INTO THE FILE. THIS ROUTINE ALSO TAKES ; CARE OF WRITING OUT AN EXITSING BLOCK IF NECESSARY. ; ON ENTRY: ; R3 IS PTR TO VIRTUAL DATA HEADER ; AC0 HAS OFFSET (IN BYTES) FROM FILE START ; R5 HAS WRITE FLAG (1 TO INDICATE WRITE TO BE PERFORMED ; AFTER ACCESS) ; ; ON EXIT: ; R3 AS ABOVE ; AC0 AS ABOVE ; R0 HAS ADDRESS OF BLOCK BUFFER ; R2 HAS OFFSET INTO BLOCK (IN BYTES) ; ; OTHER REGISTERS USED: AC1, AC2 ; VIRACC: MOV R4,-(SP) ;SAVE A COUPLE MOV R5,-(SP) ;OF REGISTERS MOV 6(R3),R4 ;LUN -> R4 DEC R4 ;BACK IT OFF BY ONE BIS #10000,R4 ;SET BLOCK MODE MOV #7400,R0 ;MASK TO IGNORE MOV R3,-(SP) ;SAVE DATA PTR JSR PC,SRCHFL ;LOOK FOR IT BEQ 4$ ;IF NOT THERE, BRANCH SETL ;SET 32 BIT INTEGER MODE STCFL AC0,-(SP) ;CONVERT OFFSET TO INTEGER MOV (SP)+,R4 ;AND PUT IN REGISTERS MOV (SP)+,R5 ;FOR FURTHER WORK ASHC #-11,R4 ;MAKE IT JUST BLOCK NUMBER ADD #1,R5 ;OFFSET BLOCK (SINCE START AT 1) ADC R4 ;MAKE SURE OF 32 BITS MOV R5,-(SP) ;STORE 32 BIT BLOCK MOV R4,-(SP) ;NUMBER ON STACK LDCLF (SP)+,AC1 ;REQUIRED BLOCK -> AC1 LDCLF 6(R3),AC2 ;CURRENT BLOCK -> AC2 CMPF AC1,AC2 ;IS REQUIRED SAME AS CURRENT? CFCC BEQ 2$ ;IF SO, BRANCH (NO NEED TO READ) JSR PC,WRITBK ;GO WRITE THE BLOCK OUT BCS 3$ ;ON ERROR, BRANCH LDCLF F.EFBK(R0),AC2 ;CURRENT EOF BLOCK # -> AC2 CMPF AC1,AC2 ;COMPARE REQUIRED VS EOF CFCC BLT 5$ ;IF REQ'D < CURRENT EOF, OK FOR READ TST 2(SP) ;CHECK ON WRITE FLAG BNE 2$ ;IF WRITE, SKIP READ ;ELSE CONTINUE SO WE GET EOF ERROR ON READ 5$: STCFL AC1,F.BKVB(R0) ;REQUIRED BLOCK NUMBER -> FDB CLR -(SP) ;IO STATUS BLOCK CLR -(SP) ;ON STACK MOV SP,F.BKST(R0) ;WITH ADDRESS IN FDB READ$ ;DO BLOCK READ BCC 6$ ;IF OK, BRANCH TO WAIT MOVB F.ERR(R0),(SP) ;IF NOT, GET ERROR CODE WHERE EXPECTING IT BR 1$ ;AND BRANCH AROUND WAIT 6$: WAIT$ R0 ;WAIT FOR IT TO FINISH 1$: MOV (SP)+,R2 ;IO STATUS RETURN -> R2 TST (SP)+ ;POP XFER COUNT MOVB R2,F.ERR(R0) ;STATUS -> FDB BMI 3$ ;ON ERROR, BRANCH 2$: STCFL AC0,-(SP) ;OFFSET -> STACK TST (SP)+ ;POP HIGH ORDER PART MOV (SP)+,R2 ;LOW PART -> R2 BIC #177000,R2 ;CLEAR OUT ALL BUT BLOCK OFFSET STCFL AC1,6(R3) ;STORE CURRENT BLOCK # MOV R3,R0 ;BASIC FDB PTR -> R0 MOV (SP)+,R3 ;RESTORE DATA PTR MOV (SP)+,R5 ;RESTORE SOME BIS R5,14(R0) ;SET WRITE FLAG IF IN R5 ADD #S.FDB+26,R0 ;MAKE R0 POINT TO BLOCK BUFFER MOV (SP)+,R4 ;REGISTERS SETI ;BACK TO 16 BIT INTEGERS RTS PC ;AND RETURN ; ; ERROR ROUTINES ; 3$: MOVB R2,R2 ;EXTEND SIGN MOV R2,PARLST+P.FCS ;STORE FCS ERROR CODE SETI ;RESTORE INTEGER MODE VFIERR ;ERROR IN VIRTUAL FILE ACCESS 4$: SETI VOPERR ;VIRTUAL FILE NOT OPEN ; ; SUBROUTINE WRITBK ; TO WRITE OUT BLOCK BUFFER ON BLOCK ACCESS FILE IF NEEDED ; AND SET UP FDB FOR BLOCK OPERATIONS ; ; ON ENTRY: ; R3 POINTS TO BASIC FILE CONTROL BLOCK HEADER ; ; ON EXIT: ; R0 POINTS TO FDB PROPER ; F.BKDS AND F.BKDS+2 SET UP ; F.BKVB(R0) SET UP WITH BLOCK NUMBER OF WRITTEN BLOCK IF WRITE DONE ; 14(R3) ZEROED (NO UNRECORDED WRITES TO THIS BLOCK) ; F.ERR(R0) SET WITH IO STATUS CODE IF WRITE DONE ; 'C' SET IF ERROR IN WRITE, CLEAR OTHERWISE ; ; OTHER REGISTERS USED:R2 ; WRITBK: MOV R3,R0 ;MAKE R0 POINT TO FCS FDB ADD #26,R0 ; MOV R0,F.BKDS+2(R0) ;STORE PROPER ADD #S.FDB,F.BKDS+2(R0) ;BLOCK ADDRESS MOV #1000,F.BKDS(R0) ;AND SIZE TST 14(R3) ;CHECK # WRITES TO THIS BLOCK BEQ 2$ ;IF NONE, BRANCH (NO NEED TO WRITE) MOV 6(R3),F.BKVB(R0);SET UP BLOCK NUMBER MOV 10(R3),F.BKVB+2(R0) ;FOR WRITE CLR -(SP) ;MAKE A STATUS BLOCK CLR -(SP) ;ON THE STACK MOV SP,F.BKST(R0) ;AND ADDRESS IN FDB WRITE$ ;DO THE BLOCK WRITE BCC 4$ ;IF OK, BRANCH TO WAIT MOVB F.ERR(R0),(SP) ;PUT ERROR CODE WHERE EXPECTING IT BR 3$ ;AND BRANCH AROUND WAIT 4$: WAIT$ R0 ;AND WAIT FOR IT TO FINISH 3$: MOV (SP)+,R2 ;IO STATUS RETURN -> R2 TST (SP)+ ;POP XFER COUNT SEC ;SET 'C' FOR ERROR RETURN MOVB R2,F.ERR(R0) ;STORE STATUS IN FDB BMI 1$ ;IF NEGATIVE, BRANCH 2$: CLC ;ELSE SET SUCCESS RETURN 1$: RTS PC .SBTTL GETNUM - TO RETURN NUMBER -> AC0, GIVEN INFO FROM GTOFFS ; ; ON ENTRY: ; R3 IS PTR TO DATA ITEM HEADER ; AC0 HAS OFFSET ; 1) FOR STANDARD VAR, OFFSET FROM STUDAT ; 2) FOR VIRTUAL ARRAY, OFFSET FROM FILE START ; ; ON EXIT: ; R3 AS ABOVE ; AC0 HAS NUMERIC VALUE ; ; OTHER REGISTERS USED: R0, R2 ; GETNUM: MOV R5,-(SP) ;SAVE CURRENT R5 CLR R5 ;NO WRITE FLAG (READ ONLY) JSR PC,NUMSUB ;GO TO COMMON READ/WRITE SUBROUTINE JMP @1$(R0) ;AND JUMP TO PROPER CODE 1$: .WORD 2$ ;FLOATING .WORD 3$ ;INTEGER .WORD 4$ ;BYTE .WORD 9$ ;DOUBLE PRECISION 2$: LDF (R2),AC0 ;LOAD IN FLOATING VALUE BR 8$ 3$: MOV (R2),R0 ;INTEGER VALUE -> R0 5$: LDCIF R0,AC0 ;CONVERT IT TO FLOATING 8$: MOV (SP)+,R5 ;RESTORE R5 RTS PC ;AND RETURN 4$: MOVB (R2),R0 ;CONVERT BYTE TO INTEGER BR 5$ ;AND FINISH LIKE INTEGER ; ; TEMPOROARILY FOR LOGICAL TIE-UP OF CODE FOR DOUBLE PRECISION ; EVENTUALLY THE USE OF DOUBLE PRECISION (REAL*8) HAS TO BE RE-THOUGHT ; 9$: LDCDF (R2),AC0 BR 8$ ; ; COMMON CODE FOR READ AND WRITE OF NUMERIC DATA ; ; ON ENTRY: ; R3 IS PTR TO DATA ITEM HEADER ; AC0 HAS OFFSET ; 1) FOR STANDARD VAR, OFFSET FROM STUDAT ; 2) FOR VIRTUAL ARRAY, OFFSET FROM FILE START ; R5 HAS READ/WRITE FLAG (0=READ, 1=WRITE) ; ; ON EXIT: ; R3,AC0,R5 AS ABOVE ; R2 HAS ADDRESS OF DATA ; R0 HAS TYPE INDICATOR ; 0 = FLOATING (REAL*4) ; 2 = INTEGER*2 ; 4 = BYTE (LOGICAL*1) ; 6 = DOUBLE (REAL*8) ; NUMSUB: MOV (R3),R0 ;ARE WE IN RANGE FOR NUMERIC DATA ASH #-14,R0 ;MAKE TYPE INFO INTO BIC #177761,R0 ;A JUMP TABLE OFFSET CMP R0,#6 ;ARE WE IN RANGE OF NUMBER TYPES BHI 8$ ;IF NOT, BRANCH TO ERROR BIT #10000,(R3) ;VIRTUAL? BNE 6$ ;IF SO, BRANCH STCFI AC0,R2 ;OFFSET -> R2 ADD STUDAT,R2 ;MAKE IT INTO ABSOLUTE ADDRESS 7$: RTS PC ; ; VIRTUAL SECTION ; 6$: MOV R0,-(SP) ;SAVE JUMP PTR JSR PC,VIRACC ;GO ACCESS APPROPRIATE BLOCK ;(RETURN WITH BLOCK ADDRESS -> R0) ;(OFFSET -> R2) BVS 8$ ;IF NO FILE, 'V' SET ADD R0,R2 ;MAKE R2 POINT TO VALUE MOV (SP)+,R0 ;RESTORE JUMP PTR BR 7$ ;AND GO FINISH LIKE REGULAR VARIABLE 8$: NXVERR .SBTTL STONUM - STORE A NUMBER FROM AC0 INTO VARIABLE ; ; ON ENTRY: ; R3 POINTS TO DATA ITEM HEADER ; AC0 HAS VALUE ; AC1 HAS OFFSET ; 1) FOR STANDARD VAR, OFFSET FROM STUDAT ; 2) FOR VIRTUAL ARRAY, OFFSET FROM FILE START ; ; ON EXIT: ; R3 AS ABOVE ; AC0 AS ABOVE ; AC1 AS ABOVE ; ; OTHER REGISTERS USED: R0, R2 ; STONUM: MOV R5,-(SP) ;SAVE R5 MOV #1,R5 ;SET WRITE FLAG STF AC0,-(SP) ;SAVE VALUE STF AC1,AC0 ;AND PUT OFFSET WHERE EXPECTED JSR PC,NUMSUB ;DO COMMON CODE LDF (SP)+,AC0 ;GET VALUE OFF STACK JMP @1$(R0) ;GO TO PROPER ROUTINE 1$: .WORD 2$ ;REAL*4 .WORD 3$ ;INTEGER*2 .WORD 4$ ;LOGICAL*1 (BYTE) .WORD 9$ ;REAL*8 2$: STF AC0,(R2) BR 8$ 3$: STCFI AC0,(R2) ;CONVERT TO 1-WORD INTEGER BR 8$ 4$: STCFI AC0,R0 ;CONVERT 1ST TO INTEGER MOVB R0,(R2) ;THEN TO BYTE 8$: MOV (SP)+,R5 ;RESTORE R5 RTS PC ; ; TEMPORARY DOUBLE PRECISION STORE ; 9$: STCFD AC0,(R2) BR 8$ .SBTTL GETSTR - TO RETURN STRING ELEMENT DESCRIPTOR IN R3,R4 ; ; ON ENTRY: ; R0 IS PTR TO DATA ITEM HEADER ; AC0 HAS OFFSET ; 1) FOR STANDARD VAR, OFFSET FROM STUDAT ; 2) FOR VIRTUAL ARRAY, OFFSET FROM FILE START ; ; ON EXIT: ; R0, AC0 AS ABOVE ; R3 HAS STRING ADDRESS ; R4 HAS STRING LENGTH ; 'V' SET IF ERROR, CLEAR OTHERWISE ; ; OTHER REGISTERS USED: ; GETSTR: MOV R5,-(SP) ;SAVE CURRENT R5 CLR R5 ;SET READ ONLY JSR PC,STRADD ;GO TO COMMON CODE BIT #10000,(R0) ;VIRTUAL? BNE 8$ ;IF SO, BRANCH TST 4(R0) ;FIXED OR VAR? BMI 1$ ;IF VAR, BRANCH MOVB 4(R0),R4 ;FIXED LEN -> R4 BR 2$ 1$: MOVB -1(R3),R4 ;ACTUAL LENGTH -> R4 2$: BIC #177400,R4 ;CLEAR ANY SIGN EXTEND BR 5$ ;AND THAT'S IT ; ; VIRTUAL STRING RETRIEVE ; 8$: MOV 10(R0),R4 ;SIZE -> R4 BPL 5$ ;IF POSITIVE, WE'RE DONE NEG R4 ;MAKE ABSOLUTE VALUE MOV R4,R2 ;GET END OF STRING ADD R3,R2 ;IN R2 4$: TSTB -(R2) ;CHECK FOR FIRST BNE 5$ ;NON-NULL (BRANCH) SOB R4,4$ ;ELSE KEEP LOOKING 5$: MOV (SP)+,R5 ;RESTORE ORIGINAL R5 RTS PC ; ; COMMON CODE FOR STRING READ AND WRITE ; ; ON ENTRY: ; R0 IS PTR TO DATA ITEM HEADER ; AC0 HAS OFFSET ; 1) FOR STANDARD VAR, OFFSET FROM STUDAT ; 2) FOR VIRTUAL ARRAY, OFFSET FROM FILE START ; R5 HAS READ/WRITE FLAG (0=READ, 1=WRITE) ; ; ON EXIT: ; R0,AC0,R5 AS ABOVE ; R3 HAS ADDRESS OF STRING ; ; OTHER REGISTERS USED: R0,R2 ; STRADD: MOV (R0),-(SP) ;HEADER ON STACK BIC #17777,(SP) ;CLEAR ALL BUT TYPE CMP #120000,(SP)+ ;IS IT STRING BNE 6$ ;IF NOT, ERROR BIT #10000,(R0) ;VIRTUAL STRING? BNE 3$ ;IF SO, BRANCH STCFI AC0,R3 ;OFFSET -> R3 ADD STUDAT,R3 ;MAKE IT ABSOLUTE 7$: RTS PC 3$: MOV R0,R3 ;GET HEADER WHERE WE NEED IT MOV R0,-(SP) ;AND SAVE SINCE R0 GETS USED JSR PC,VIRACC ;GO ACCESS THE ITEM MOV R0,R3 ;BLOCK ADDRESS -> R3 ADD R2,R3 ;NOW ABS ADDRESS MOV (SP)+,R0 ;HEADER ADDRESS BACK -> R0 BR 7$ 6$: NXVERR ;THIS ERROR SHOULDN'T HAPPEN .SBTTL STOSTR - STORE STRING IN MEMORY (REAL OR VIRTUAL) ; ; ON ENTRY: ; R0 IS PTR TO DATA ITEM HEADER ; AC0 HAS OFFSET ; 1) FOR STANDARD VAR, OFFSET FROM STUDAT ; 2) FOR VIRTUAL ARRAY, OFFSET FROM FILE START ; R3 HAS STRING ADDRESS ; R4 HAS STRING LENGTH ; ; ON EXIT: ; R0, AC0 AS ABOVE ; R3 HAS ADDRESS PAST END OF USED PORTION OF SOURCE STRING ; R4 = 0 ; STOSTR: MOV R5,-(SP) ;SAVE A REGISTER MOV R3,-(SP) ;SAVE STRING DESCRIPTORS MOV R4,-(SP) MOV #1,R5 ;SET WRITE FLAG JSR PC,STRADD ;GO DO COMMON CODE MOV R3,R2 ;DESTINATION ADDRESS -> R2 MOV (SP)+,R4 ;POP LENGTH MOV (SP)+,R3 ;AND ADDRESS OF DESTINATION BIT #10000,(R0) ;VIRTUAL DESTINATION? BNE 4$ ;IF SO, BRANCH MOVB 4(R0),R5 ;MAX LEN -> R5 BIC #177400,R5 ;CLEAR OUT ANY SIGN EXTEND SUB R4,R5 ;R5 HAS DIFFERENCE BETWEEN MAX AND ACTUAL BGE 1$ ;IF POS OR ZERO, OK (BRANCH) ADD R5,R4 ;IF NEGATIVE, REDUCE ACTUAL TO MAX CLR R5 ;AND SET ZERO DIFFERENCE (FOR FILL) 1$: MOV R0,-(SP) ;SAVE DATA ITEM HEADER TST 4(R0) ;CHECK FIXED OR VARIABLE BMI 2$ ;IF VARIABLE, BRANCH MOVB #40,R0 ;IF FIXED USE SPACE AS FILL CHAR BR 3$ 2$: MOVB R4,-1(R2) ;STORE ACTUAL LENGTH IN ITS FIELD CLR R0 ;USE NULL AS FILL 3$: JSR PC,FILSTR ;GO FILL THE STRING MOV (SP)+,R0 ;RESTORE DATA ITEM PTR MOV (SP)+,R5 ;AND REGISTER WE USED RTS PC ; ; VIRTUAL STRING SECTION ; 4$: MOV R0,-(SP) ;SAVE DATA ITEM PTR MOV 10(R0),R5 ;GET STRING LENGTH -> R5 BPL 5$ ;IF POSITIVE THEN FIXED (BRANCH) CLR R0 ;IF NEGATIVE, THEN VARIABLE => NULL FILL NEG R5 ;MAKE LENGTH POSITIVE BR 6$ 5$: MOV #40,R0 ;USE SPACE FILL FOR FIXED LENGTH 6$: SUB R4,R5 ;LENGTH DIFFERENCE -> R5 BGE 3$ ;IF POSITIVE, WE'RE SET NOW ADD R5,R4 ;IF NEG, MAKE LEN = MAX LEN CLR R5 ;AND NO FILL BR 3$ ;AND GO FINISH FILL OPERATION ; ; FILSTR ; TO FILL IN A STRING VARIABLE ; ; ON ENTRY: ; R3 HAS ADDRESS OF SOURCE ; R4 HAS LEN OF SOURCE ; R2 HAS ADDRESS OF VARIABLE ; R5 HAS FILL COUNT ; R0 HAS FILL CHAR ; ; ON EXIT: ; R4 = 0 ; R5 = 0 ; R3 HAS ADDRESS PAST END OF USED SOURCE ; R2 HAS ADDRESS PAST END OF FILLED VARIABLE ; R0 HAS FILL CHAR ; FILSTR: TST R4 ;DO WE HAVE AN ACTUAL STRING? BEQ 2$ ;IF NOT, BRANCH 1$: MOVB (R3)+,(R2)+ ;MOVE IN THE ACTUAL STRING SOB R4,1$ ; 2$: TST R5 ;DO WE HAVE ANY FILL TO DO? BEQ 4$ ;IF NOT, BRANCH 3$: MOVB R0,(R2)+ ;MOVE IN THE FILL CHARACTERS SOB R5,3$ 4$: RTS PC .SBTTL NEWVAR - TO CREATE A SIMPLE VARIABLE OF R0 TYPE ; ; ON ENTRY: ; R0 HAS TYPE INDICATOR ; 0 = REAL*4 ; 2 = INTEGER ; 4 = BYTE ; 6 = REAL*8 ; 10= STRING ; R4 HAS VARIABLE HEADER ; LOWER 12 BITS HAVE VAR. NAME ; TOP 3 BITS ARE DATA TYPE ; ; ON EXIT: ; R0 AND R4 AS ABOVE ; R3 POINTS TO DATA ITEM HEADER ; ENUDAT UPDATED ; ; OTHER REGISTERS USED: R5 ; NEWVAR: MOV R4,-(SP) ;SAVE HEADER ASR R0 ;DIVIDE INDEX BY TWO MOV R0,-(SP) ;AND SAVE IT MOVB 10$(R0),R0 ;GET ITEM SIZE -> R0 TSTOK ;CHECK FOR ROOM BLO 12$ ;IF NOT ENOUGH, ERROR MOV (SP)+,R0 ;RESTORE JUMP POINTER MOV (SP),R4 ;AND HEADER MOV R5,R3 ;COPY DATA ITEM START -> R3 MOV R4,(R5)+ ;PUT IN HEADER CLR (R5)+ ;SET ZERO DIMENSIONS CMP R0,#4 ;STRING? BNE 1$ ;IF NOT, BRANCH MOV #177417,(R5)+ ;IF SO, SET VAR LENGTH 15 BYTE STRING 1$: MOVB 11$(R0),R4 ;GET WORD COUNT TO CLEAR -> R4 2$: CLR (R5)+ ;AND SOB R4,2$ ;CLEAR SPACE MOV R5,ENUDAT ;SAVE NEW END OF DATA MOV (SP)+,R4 ;RESTORE DATA HEADER ASL R0 ;AND TYPE INDEX RTS PC 12$: OVFERR 10$: .BYTE 10,6,6,14,26 ;REAL*4,INTEGER,BYTE,REAL*8,STRING 11$: .BYTE 2,1,1,4,10 ; " " .EVEN .SBTTL LET00 - LET STATEMENT ;+3 ; .SKIP ; .X ^^LET\\ ; .X ^ARITHMETIC ASSIGNMENT ; .INDENT -5 ; ^^ ; LET ; \\ ; .BREAK ; ^THIS IS THE NUMERIC ASSIGNMENT STATEMENT. ; ^IT IS ALSO ALLOWABLE FOR STRING ASSIGNMENT. ; ^THE WORD ITSELF IS OPTIONAL IN THIS VERSION OF ^^BASIC\\. ; ^A SINGLE VARIABLE NAME TO THE LEFT OF THE '=' IS GIVEN ; THE VALUE OF THE NUMERIC OR STRING EXPRESSION TO THE RIGHT ; OF THE EQUAL SIGN. ; ^VARIABLE AND EXPRESSION TYPES MUST MATCH. ; .BREAK ; ^EXAMPLE: ; .NOFILL ; ^^ ; 20 LET A=EXP(10.34) ; 30 A$="ABC"+B$ ; \\ ; .FILL ;- ; REGISTERS USED - ALL. ; LET00: JSR PC,GETHDR ;GET VARIABLE HEADER BVS 97$ ;IF NO VARIABLE IN TEXT, ERROR BNE 4$ ;IF ALREADY DEFINED, BRANCH JSR PC,NEWVAR ;ELSE DEFINE IT NOW 4$: MOV R0,-(SP) ;SAVE JUMP PTR JSR PC,GTOFFS ;GET OFFSET (REAL OR VIRTUAL) MOV (SP)+,R0 ;RESTORE JUMP PTR MOV R3,-(SP) ;SAVE DATA HEADER ADDRESS STF AC0,-(SP) ;AND DATA OFFSET SKIP ;GET NEXT CHAR CMPB R2,#'= ;MUST BE '=' BNE 97$ ;ELSE ERROR CMP R0,#10 ;STRING? BEQ 10$ ;IF SO, BRANCH TO STRING SECTION 2$: EVAL ;GET SOURCE VALUE -> AC0 BVS 98$ ;IF ERROR, REPORT IT LDF (SP)+,AC1 ;OFFSET -> AC1 MOV (SP)+,R3 ;RESTORE DATA ITEM HEADER JSR PC,STONUM ;STORE NUMBER BR 12$ ;AND BACK TO MAIN INTERPRETER ; ; STRING SECTION OF LET ; 10$: EVALS ;EVALUATE SOURCE STRING (R3,R4) BVS 99$ ;ON ERROR, BRANCH LDF (SP)+,AC0 ;RESTORE OFFSET MOV (SP)+,R0 ;AND DATA HEADER ADDRESS JSR PC,STOSTR ;STORE RESULT 12$: JMP INIT02 ;AND BACK TO INTERPRETER 97$: UNRERR ;UNRECOGNIZED STATEMENT 98$: PARERR 99$: LETERR .SBTTL EVALC0 - EVALUATE LOGICAL CONDITION ;+1 ; .SKIP ; .X ^LOGICAL ^EXPRESSIONS ; .ID -5 ; ^LOGICAL ^EXPRESSIONS ; .BR ; ^LOGICAL EXPRESSIONS ARE OF THE FORM: ; .BR ; ^^___[___...] ; \\ ; .BR ; ^WHERE EXPRESSIONS ARE EITHER ARITHMETIC OR STRING AND RELATIONAL OPERATORS ; CAN BE FORMED BY ANY COMBINATION OF _<, > AND =. ; ^THE TWO EXPRESSIONS WHICH ARE RELATED BY THE RELATIONAL OPERATOR MUST BE ; OF THE SAME TYPE: I.E. STRING OR ARITHMETIC. ; ^THE RESULT OF EVALUATING THE RELATIONSHIP (TERMED HERE A LOGICAL ; SUBEXPRESSION) IS EITHER TRUE OR FALSE. ; ^STRINGS ARE COMPARED CHARACTER BY CHARACTER ON THE BASIS OF THEIR = 5) ; \\ ; .F ;- ; ; THIS CODE EVALUATES A COMPOUND CONDITION, ALLOWING FOUR LOGICAL ; OPERATORS: NOT, AND, XOR, OR. ; ; ON ENTRY: ; R1 POINTS TO START OF CONDITION TEXT ; ON EXIT: ; R1 POINTS TO NEXT CHAR OF TEXT ; R0 HAS CONDITION -1 = TRUE, 0 = FALSE ; 'N' SET IF TRUE ; 'Z' SET IF FALSE ; EVALC0: CLR -(SP) ;SET STOPPER ON STACK 1$: SKIP ;FIRST CHAR -> R2 BIC #177400,R2 ;CLEAR ANY SIGN EXTEND CMPB R2,#'( ;OPEN PAREN? BEQ 12$ ;IF SO, BRANCH CMPB R2,#S.NOT ;IS IT A LEADING 'NOT' BNE 2$ ;IF NOT, BRANCH MOV R2,-(SP) ;IF SO, SAVE IT BR 1$ ;AND GO BACK FOR MORE 2$: DEC R1 ;BACK UP TEXT POINTER JSR PC,SNGLCN ;GO EVALUATE SINGLE CONDITION 8$: MOV (SP)+,R3 ;SEE WHAT'S ON STACK BEQ 11$ ;IF ZERO, BRANCH SUB #S.NOT,R3 ;ANYTHING ELSE IS AN OPERATOR ASL R3 ;MAKE IT INTO A TABLE OFFSET JMP @3$(R3) ;AND GO TO APPROPRIATE ROUTINE 3$: .WORD 4$ ;NOT .WORD 5$ ;AND .WORD 6$ ;XOR .WORD 7$ ;OR 4$: COM R0 ;COMPLEMENT THE EXISTING CONDITION BR 8$ ;AND SEE IF ANYTHING MORE ON STACK 5$: MOV (SP)+,R2 ;PRIOR CONDITION -> R2 COM R2 ;HAVE TO FUSS TO GET BIC R2,R0 ;LOGICAL AND BR 9$ ;NOW SEE WHAT'S NEXT 6$: MOV (SP)+,R2 ;GET PRIOR CONDITION -> R2 XOR R2,R0 ;WE HAVE INSTRUCTION FOR EXCLUSIVE OR BR 9$ 7$: BIS (SP)+,R0 ;THIS IS THE INSTRUCTION FOR INCL. OR 9$: SKIP ;GET NEXT CHAR -> R2 BIC #177400,R2 ;CLEAR ANY SIGN EXTEND CMPB R2,#S.AND ;SEE IF WE HAVE BINARY BLO 10$ ;LOGICAL OPERATOR CMPB R2,#S.OR BHI 10$ ;IF NOT, AT END OF CONDITION MOV R0,-(SP) ;IF SO, PUT CURRENT CONDITION MOV R2,-(SP) ;AND OPERATOR ON STACK BR 1$ ;AND EVALUATE NEXT CONDITION 10$: DEC R1 ;BACK UP TEXT POINTER TST (SP)+ ;POP STOPPER FROM STACK TST R0 ;SET CONDITION CODES RTS PC ;AND RETURN 11$: CLR -(SP) ;RESET STOPPER BR 9$ ;AND GO LOOK FOR BINARY OPERATOR 12$: JSR PC,EVALC0 ;CALL THIS ROUTINE RECURSIVELY SKIP ;NEXT CHAR -> R2 CMPB R2,#') ;IS IT CLOSE PAREN? BEQ 8$ ;IF SO, BRANCH PARERR S.LT =1 ;DEFINE BITS FOR RELATIONAL OPERATORS S.EQ =2 S.GT =4 SNGLCN: EVALS ;IF STRING OK BVC 1$ ;GO DO STRING COMPARE EVAL BVC 10$ ;IF NO PAREN, BRANCH PARERR ;CLOSE PAREN HERE IS ERROR 10$: STF AC0,-(SP) ;SAVE THE VALUE CLR -(SP) ;SPACE TO SET TRUE CONDITIONS JSR PC,OPSET ;SET THE TRUE CONDITIONS EVAL ;GET SECOND ARG -> AC0 BVC 12$ ;IF NO CLOSE PAREN, BRANCH DEC R1 ;IF ONE, BACK UP OVER IT 12$: MOV (SP)+,R0 ;CONDITIONS IN R0 CMPF (SP)+,AC0 ;DO ACTUAL COMPARE CFCC ;COPY THE CONDITION CODES BR 6$ ;GO FINISH 1$: MOV R4,-(SP) ;SAVE LEN AND MOV R3,-(SP) ;ADDRESS OF FIRST STRING MOV ENUDAT,-(SP) ;SAVE OLD STORAGE END CLR -(SP) ;SAVE SLOT FOR TRUE CONDITIONS MOV R3,R5 ;SET NEW END OF ADD R4,R5 ;USER STORAGE PAST INC R5 ;FIRST STRING BIC #1,R5 MOV R5,ENUDAT JSR PC,OPSET ;SET TRUE REL OPERATORS EVALS ;GET SECOND STRING BVS IF99 ;ON ERROR, BRANCH MOV (SP)+,R0 ;GET TRUE CODES IN R0 MOV (SP)+,ENUDAT ;RESTORE OLD END OF USER STORAGE MOV (SP)+,R2 ;1ST STRING ADDRESS -> R2 MOV (SP)+,R5 ;ITS LEN -> R5 CLR -(SP) ;PUT LENGTH RELATIONAL FLAG ON STACK CMP R5,R4 ;COMPARE 1ST LEN TO SECOND BEQ 2$ ;IF SAME, DON'T DO ANYTHING YET BLT 3$ ;IF LESS, GO SET NEG & NEW COMPARE COUNT INC (SP) ;IF GT, SET POS BR 2$ ;AND KEEP PRESENT COMPARE COUNT (R4) 3$: DEC (SP) MOV R5,R4 ;MIN LENGTH IN R4 2$: MOV (SP)+,R5 ;LEN RELATION IN R5 TST R4 ;CHECK LENGTH BLE 5$ ;IF NEG OR ZERO, GO BY LEN ONLY 4$: CMPB (R2)+,(R3)+ ;CHECK EACH CHAR. BNE 6$ ;IF DON'T MATCH, END OF COMPARE SOB R4,4$ ;KEEP COMPARING 5$: TST R5 ;IF FINISHED CHECK, GO ON LEN 6$: BLT 7$ ;GO TO APPROPRIATE TEST FOR TRUE BEQ 8$ ;CONDITIONS BIT #S.GT,R0 ;IS > TRUE BR 9$ 7$: BIT #S.LT,R0 ;IS < TRUE BR 9$ 8$: BIT #S.EQ,R0 ;IS = TRUE 9$: BEQ 11$ ;IF FALSE, BRANCH MOV #-1,R0 ;SET TRUE CONDITION RTS PC 11$: CLR R0 ;SET FALSE CONDITION RTS PC .SBTTL IF00 - IF STATEMENT ;+3 ; .SKIP ; .X ^^IF\\ ; .X ^STRING COMPARISON ; .INDENT -5 ; ^^ ; IF ; \\ ; .BREAK ; .NOFILL ; ^FORMAT: ; ^^IF _ THEN _[ELSE _][ELSE _] ; IF _ THEN _ " " ; IF _ GOTO _\\ " " ; .FILL ; ^IF THE LOGICAL EXPRESSION IS TRUE (SEE ^LOGICAL ^EXPRESSIONS), THEN ; THE LINE NUMBER FOLLOWING THE B THEN STOP ; 20 IF A$ _<> B$ GOTO 110 ELSE 500 ; 30 IF A >= 12.5 THEN 160 ELSE PRINT "A _< 12.5" : GOTO 300 ; \\ ; .FILL ;- ; REGISTERS USED - ALL. ; IF00: JSR PC,EVALC0 ;EVALUATE CONDITION BNE IF15 ;IF TRUE, BRANCH MOV #1,R0 ;ACCOUNT FOR CURRENT IF 1$: MOVB (R1)+,R2 ;GET NEXT CHAR CMPB R2,#S.IF ;IS IT IF? BLO 1$ ;IF LESS, NOT INTERESTING AT ALL BNE 2$ ;IF NOT SAME, BRANCH INC R0 ;IF SO, COUNT IT BR 1$ ;AND KEEP LOOKING FOR ELSE 2$: CMPB R2,#S.EOS1 ;END OF ANY STATEMENT? BLO 3$ ;IF NOT, BRANCH CMPB R2,#S.EOL2 ;END OF LOGICAL LINE? BEQ 4$ ;IF SO, BRANCH INC STCOUN ;KEEP TRACK OF STATEMENTS FOR GOSUB ETC. BR 1$ 4$: DEC R1 ;ELSE BACK UP JMP INIT02 ;AND GIVE UP 3$: CMPB R2,#S.ELSE ;DO WE HAVE AN ELSE? BNE 1$ ;IF NOT, KEEP LOOKING INC STCOUN ;ESLE'S COUNT AS NEW STATEMENT! DEC R0 ;ALSO, COUNT DOWN THE IF'S BNE 1$ ;IF NOT ZERO, KEEP LOOKING BR IF01 ;IF THIS IS IT, GO TO IT REM00: MOV LINEHD,R5 ;CURRENT LINE HEADER -> R5 MOV R1,-(SP) ;SAVE CURRENT TEXT PTR MOV 2(R5),R1 ;START OF LINE OFFSET -> R1 ADD USR,R1 ;ADD IN OFFSET OF PROGRAM TEXT CLR R0 ;CLEAR FLAG SKIP ;GET FIRST SIGNIFICANT THING IN CURRENT LINE MOV R1,R3 ;SAVE POSITION IN R3 MOV (SP)+,R1 ;AND GET BACK OUR REAL POSITION CMP R3,R1 ;DO THE TWO MATCH? BNE 2$ ;IF NOT, BRANCH (WE ARE NOT AT START OF LINE) INC R0 ;IF MATCH, SET FLAG THAT THIS IS FIRST THING 2$: CMPB (R1)+,#S.EOL1 ;LOOK FOR END OF PHYSICAL LINE BLO 2$ BNE 1$ ;IF NOT END OF PHYSICAL LINE, BRANCH MOVB #S.EOS1,R2 ;FAKE END OF STATEMENT TST R0 ;WERE WE AT START OF LINE BEQ 3$ ;IF NOT, BRANCH DEC STCOUN ;IF SO, BACK US OFF TO ZERO NOW ;SO RETURN AND NEXT WORK PROPERLY 3$: JMP INIT03 ;AND JUMP INTO MIDDLE OF INTERPRETER 1$: DEC R1 ;BACK UP JMP INIT02 ;AND DO THINGS REGULAR ;+3 ; .SL ; .X ^^REM\\ ; .X ! ; .SL ; .ID -5 ; ^^ ; REM ; .BR ; .ID -5 ; ! ; \\ ; .BR ; ^THE ^^REM\\ARK STATEMENT IS USED TO INSERT COMMENTS INTO THE TEXT ; OF THE ^^BASIC\\ PROGRAM. ; ^IT HAS TWO FORMS: ^^REM\\ AND !. ; ^ALL TEXT FOLLOWING THE ^^REM\\ OR ! WILL BE IGNORED BY THE ; ^^BASIC\\ INTERPRETER UP TO THE END OF A PHYSICAL LINE. ; ^NO OTHER STATEMENTS MAY FOLLOW ON THE SAME LINE AS THEY ARE TREATED ; AS PART OF THE COMMENT. ; .BR ; ^EXAMPLE: ; .NF ; ^^ ; 10 REM PROGRAM TO ADD ALL NUMBERS FROM 1 TO 10 ; 20 ! AND DEMONSTRATE USE OF REM AND ! ; \\ ; .FILL ;- IF15: SKIP ;NEXT CHAR CMPB R2,#S.THEN ;IS IT THEN BNE IF09 ;IF NOT, TRY FOR GOTO IF01: SKIP ;SKIP OVER BLANKS DEC R1 ;POINT AT CHARACTER TSTCH ;CHECK NUMERIC BVS IF08 ;MUST BE A CODE .GT. 140 BNE IF08 ;ASSUME LET STATEMENT IF ALPHA IF10: JMP GOTO00 ;MAKE IT A GO TO IF08: JMP INIT10 ;GO BACK TO FIGURE OUT THE REST IF09: CMPB R2,#S.GOTO ;IS IT GOTO BEQ IF10 ;IF SO, GO DO IT IF99: IFERR ;ILLEGAL IF OPSET: SKIP ;GET CHAR CMPB R2,#'< ;IS IT ONE OF BEQ 1$ CMPB R2,#'= ;THE LEGAL BEQ 2$ CMPB R2,#'> ;RELATIONAL OPERATORS BEQ 3$ DEC R1 ;IF NOT, BACK UP POINTER TST 2(SP) ;CHECK FOR AT LEAST ONE OPERATOR BNE 4$ ;IF SO, RETURN OPRERR ;ELSE ERROR 4$: RTS PC 1$: BIS #S.LT,2(SP) ;SET APPROPRIATE BR OPSET 2$: BIS #S.EQ,2(SP) ;OPERATOR FLAG BIT BR OPSET 3$: BIS #S.GT,2(SP) ;ON THE STACK BR OPSET .SBTTL PR00 - PRINT STATEMENT ;+3 ; .SKIP ; .X ^^PRINT\\ ; .X ^BINARY OUTPUT ; .X ^RANDOM ACCESS ^I/^O ; .INDENT -5 ; ^^ ; PRINT ; \\ ; .BREAK ; ^PRINT STATEMENT. ; .NOFILL ; ^FORMAT: ; ^^PRINT [_#N,]V1,V2,V3\\ ETC. ; OR ; ^^PRINT _#N@R,V1,V2,V3\\ ETC. ; .FILL ; ^WHERE ^N IS AN OPTIONAL FILE NUMBER AND ^V1, ^V2, ^V3, ETC. ; ARE ANY LEGAL NUMERIC OR STRING EXPRESSION. ; ^IN THE SECOND FORM ^R IS A RANDOM ACCESS RECORD NUMBER EXPRESSION. ; ^IT MAY HAVE ANY VALUE UP TO THE MAXIMUM ALLOWED IN A DOUBLE ; PRECISION SIGNED INTEGER. ; ^FLOATING POINT VALUES ARE TRUNCATED BEFORE USE. ; ^THE FILE ^N MUST HAVE BEEN OPENED FOR RANDOM ACCESS VIA THE ; ^^/RN\\ SWITCH IN THE ^^OPEN\\ STATEMENT. ; .SL ; ^WHEN EXPRESSIONS ARE SEPARATED BY COMMAS, RESULTS ARE PRINTED ; IN FIELDS OF 14 CHARACTERS EACH. ; ^WHEN EXPRESSIONS ARE SEPARATED BY SEMICOLONS, RESULTS ARE PRINTED ; NEXT TO EACH OTHER WITHOUT ANY SPACES ADDED. ; ^A TRAILING SEMICOLON WILL SUPPRESS ^^__\\. ; ^WHEN PRINTING WITH COMMA SEPARATION, AS MANY FIELDS ARE ALLOWED AS ; CAN FIT ON THE PRINTING DEVICE. ; ^NOTE THAT NUMERIC VALUES, WHEN CONVERTED IN A ^^PRINT\\ STATEMENT ; NORMALLY HAVE A SPACE AT EACH END. ; ^TO AVOID THIS, USE THE ^^STR$\\ FUNCTION. ; .SKIP ; ^ON BINARY FILES, THE FOLLOWING CONDITIONS HOLD: ^^TAB\\ IS IGNORED, ; NO "FIELD" JUSTIFICATION IS PERFORMED AND ALL DATA LIST ITEMS MUST FIT ; INTO THE EXISTING BUFFER. ; ^FLOATING VALUES ARE STORED AS FOUR CONSECUTIVE BYTES WHICH ARE NOT ; WORD ALIGNED. ; ^STRINGS AND NUMERIC VALUES ARE PACKED TOGETHER AND MAY BE COMBINED IN ; ANY ORDER. ; ^IT IS UP TO THE USER TO KEEP TRACK OF THE INTERNAL STORAGE ARRANGEMENT ; FOR FUTURE USE WITH ^^INPUT\\ OR OTHER NON-^^BASIC\\ PROGRAMS. ; .SL ; ^A SYNONYM FOR ^^PRINT\\ IS "?" PRIMARILY FOR CONVENIENCE IN IMMEDIATE ; MODE USE. ; .SL ; ^EXAMPLE: ; .NOFILL ; ^^ ; 50 PRINT A,3.5,"HELLO";A$ ; 60 PRINT _#3,EXP(.5);X^Y; ; \\ ; .FILL ;- ;+4 ; .SKIP ; .X ^^TAB\\ ; .X ^PRINT TAB FUNCTION ; .INDENT -5 ; ^^ ; TAB ; \\ ; .BREAK ; ^THE ^^TAB\\ FUNCTION IS USED ONLY IN THE PRINT STATEMENT TO SPACE ; TO A GIVEN COLUMN (THE VALUE OF THE NUMERIC ARGUMENT). ; ^THE COLUMN SPECIFIED IS THE ONE IN WHICH SUBSEQUENT PRINTING WILL ; BEGIN. ; ^COLUMNS ARE NUMBERED STARTING WITH 1. ; ^IF THE SPECIFIED COLUMN IS GREATER THAN THE WIDTH OF THE DEVICE BEING ; PRINTED ON, THE TAB IS CALCULATED MODULO THE DEVICE WIDTH. ; ^IF THE SPECIFIED COLUMN IS LESS THAN THE CURRENT PRINT POSITION, THE ; FUNCTION IS IGNORED. ; ^^TAB\\ IS IGNORED ON BINARY OUTPUT FILES. ; .BREAK ; ^EXAMPLE: ; .NOFILL ; ^^ ; 10 PRINT A;TAB(20);A$ ; \\ ; .FILL ;- ; REGISTERS USED 0,1,2,3,4-OR ALL FOR SHORT ; ASCTAB: .ASCII /TAB(/ ;STRING FOR COMPARISON .EVEN PR00: MOV #1000,R0 ;SET FOR OUTPUT OK WANTED FNMBR ;SETUP FILE IF SPECIFIED MOV OTPT,R3 ;FCB POINTER -> R3 MOV 14(R3),R3 ;FDB POINTER -> R3 CMP R3,#OUTQIO ;IS THIS TERMINAL OUTPUT? BEQ 2$ ;IF SO, IT'S ASCII NO MATTER WHAT! BITB #FD.CR!FD.FTN,F.RATT(R3) ;IF CARR CNTL BNE 2$ ;BRANCH (NOT BINARY FILE) BIS #2,LINEFL ;SET BINARY BIT 2$: CLR -(SP) ;A SWITCH TO FORCE A DELIMITER PR01: MOV #34,R0 ;MAKE SURE THIS MAY BYTES ARE AVAILABLE TSTOK ;AND FIND OUT FOR SURE BLO PR02 ;JUMP IF NOT AVAILABLE SKIP ;GET THE NEXT CHARACTER CMPB R2,#', ;CHECK FOR A VALID DELIMITER BEQ PR04 ;IS IT A COMMA? CMPB R2,#'; BEQ PR09 ;IS IT A SEMI-COLON? JSR PC,EOSCHK ;IS THIS END OF STATEMENT? BEQ PR13 ;IF SO, GO TO FINAL CODE TST (SP) ;IT'S NOT A DELIMITER BLT PR11 ;IF NEGATIVE THEN WE WANTED ONE! DEC R1 ;BACK UP TO THE START OF THE EXPRESSION MOV R1,R3 ;SET UP FOR TAB CHECK MOV #ASCTAB,R2 MOV #4,R4 JSR PC,STRCMP BEQ PR03 ;IF TAB, PROCESS IT EVALS ;TRY FOR STRING EXPRESSION BVC PR15 ;BR IF VALID STRING EXPRESSION EVAL ;GO FIND THE VALUE BVS PR11 ;OVERFLOW IS AN ERROR TST LINEFL ;BINARY? BEQ 1$ ;IF NOT, BRANCH MOV OTPT,R3 ;FCB POINTER -> R3 MOV 2(R3),R2 ;MAX BYTE COUNT -> R2 SUB 6(R3),R2 ;#BYTES LEFT -> R2 CMP R2,#4 ;ENOUGH? BGE 2$ ;IF YES, BRANCH PRNERR ;(REPLACE WITH MORE SPECIFIC ERROR IN FUTURE) 2$: STF AC0,-(SP) ;GET 4 BYTE VALUE ON STACK MOV SP,R0 ;R0 IS POINTER TO VALUE MOV #4,R2 ADD R2,6(R3) ;ADJUST ACTUAL BYTE COUNT ADD R2,SP ;RESET THE STACK MOV (R3),R4 ;CURRENT BUFFER PTR -> R4 3$: MOVB (R0)+,(R4)+ ;PUT VALUE AWAY SOB R2,3$ MOV R4,(R3) ;SAVE BUFFER POINTER BR PR17 1$: MOV R1,-(SP) ;SAVE THE TEXT POINTER JSR PC,FTOA00 MOV SP,R0 ;THE OUTPUT AREA WAS LEFT ON THE STACK PRINTL ADD #24,SP ;REMOVE THE OUTPUT AREA PR10: MOV (SP)+,R1 ;RESTORE THE TEXT POINTER PR17: MOV #-1,(SP) ;FORCE A DELIMITER PR12: BR PR01 PR04: TST LINEFL ;BINARY? BNE PR09 ;IF SO, SKIP JUSTIFICATION MOV OTPT,R2 ;CONTROL BLOCK POINTER IN R2 MOV 6(R2),R0 ;ACTUAL BYTE COUNT IN R0 MOV 2(R2),R2 ;MAX BYTE COUNT IN R2 SUB #14,R2 ;SUBTRACT LENGTH OF ONE ZONE CMP R0,R2 ;ENOUGH ROOM TO JUSTIFY? BLT 1$ ;IF SO GO DO IT JSR PC,PR18 ;PUT OUT THE LINE BR PR05 ;ACT AS THOUGH WE HAD A TERMINATOR 1$: CMP OTPT,#TOTPT ;IS THIS THE TERMINAL? BNE PR05 ;IF NOT DON'T ACCOUNT FOR CARR CONT. DEC R0 ;ACCOUNT FOR FORTRAN CARR. CONTROL PR05: NEG R0 ;CALCULATE THE MOD 14 COUNT PR06: BGT PR07 ;ADD 14 UNTIL A POSITIVE RESULT ADD #14.,R0 ;ADD AND GO AGAIN BR PR06 PR07: MOVB #040,R2 ;OUTPUT SPACES PR08: PRINTC DEC R0 ;DECREMENT THE MOD 14 COUNTER BGT PR08 ;LOOP IF MORE TO DO PR09: MOV #1,(SP) ;SET DELIMITER FOUND SWITCH BR PR01 PR11: PRNERR ;ISSUE FATAL ERROR PR13: TST (SP)+ ;CHECK FOR TRAILING DELIMITER BGT PR14 ;NEGATIVE OR ZERO MEANS CRLF JSR PC,PR18 PR14: DEC R1 ;BACK UP TO THE TERMINATOR CLR LINEFL ;CLEAN UP FLAGS JMP INIT02 ;BACK TO THE INTERPRETER PR02: OVFERR ;STORAGE OVERFLOW IN PRINT PR15: TST R4 ;CHECK STRING LENGTH BEQ PR17 ;IGNORE IF NULL TST LINEFL ;BINARY OUTPUT? BEQ PR16 ;IF NOT, SKIP TEST MOV OTPT,R0 ;FCB ADD -> R0 MOV 2(R0),R2 ;MAX BYTE COUNT -> R2 SUB 6(R0),R2 ;BYTES LEFT -> R2 CMP R4,R2 ;ENOUGH ROOM? BGT PR11 ;IF NOT, ERROR PR16: MOVB (R3)+,R2 ;GET CHAR IN R2 PRINTC ;PRINT IT SOB R4,PR16 ;KEEP GOING TILL DONE CLR (SP) ;SET NO DELIMITER BR PR12 ;AND CONTINUE PR03: MOV R3,R1 ;UPDATE TEXT POINTER EVAL ;GET TAB NUMBER BVC PR11 ;MUST END WITH ')' TST LINEFL ;IF BINARY, SKIP BNE PR17 ;REST OF TAB NONSENSE MOV R1,-(SP) ;SAVE TEXT POINTER MOV OTPT,R2 ;CONTROL BLOCK POINTER -> R2 MOV 6(R2),R0 ;ACTUAL COUNT IN R0 5$: MOV 2(R2),R2 ;MAX COUNT IN R2 STCFI AC0,R4 ;TAB COUNT IN R4 DEC R4 ;WANT TO END JUST BEFORE DESIRED COL 2$: CMP R4,R2 ;GET COLUMN IN RANGE BLT 1$ ;BY SUBTRACTING MODULO SUB R2,R4 ;OUTPUT WIDTH BR 2$ 1$: CMP R4,R0 ;RELATIVE TO OUTPUT POINTER BLE 3$ ;WHERE ARE WE? SUB R0,R4 ;GET SPACE COUNT IN R4 MOVB #40,R2 ;CHAR TO OUTPUT IN R2 (SPACE) 4$: PRINTC SOB R4,4$ 3$: BR PR10 ;GO FINISH UP PR18: TSTB WPASFL ;WRITE PASS ALL SET? BEQ 1$ ;IF NOT, BRANCH MOV #IO.WLB!TF.WAL,OUTQIO+Q.IOFN ;SET WRITE PASS ALL FCN CODE CLRB OUTQIO+Q.IOPL+4 ;SET NO CARR CONTROL 1$: CRLF RTS PC .SBTTL INP00 - INPUT STATEMENT PROCESSOR ;+3 ; .TP 6 ; .SKIP ; .X ^^INPUT\\ ; .X ^BINARY INPUT ; .X ^RANDOM ACCESS ^I/^O ; .INDENT -5 ; ^^ ; INPUT ; \\ ; .BREAK ; .NOFILL ; ^FORMAT: ; ^^INPUT [_#N,] V1,V2,V3\\ ETC. ; OR ; ^^INPUT _#N@R,V1,V2,V3\\ ETC. ; .FILL ; ^WHERE ^N IS AN OPTIONAL FILE NUMBER AND ^V1, ^V2, ^V3 ETC. ARE ; LEGAL STRING OR NUMERIC VARIABLE NAMES. ; ^THE SECOND FORM FOLLOWS THE RULES FOR RANDOM ACCESS DESCRIBED ; FOR THE ^^PRINT\\ STATEMENT. ; ^NUMERIC DATA MUST BE SEPARATED BY COMMAS OR SPACES, SUCCESSIVE ; STRING VARIABLES MUST BE SEPARATED BY A COMMA AFTER THE REQUIRED NUMBER ; OF CHARACTERS HAVE BEEN TYPED IN. ; ^A CHARACTER LEGALITY CHECK IS PERFORMED TO ENSURE THAT ALL CHARACTERS ; ARE BETWEEN OCTAL ^^ASCII\\ CODES 40 AND 137 INCLUSIVE AND 11 (TAB). ; .SKIP ; ^FOR INPUT FROM THE TERMINAL (NO FILE NUMBER), A PROMPT STRING ; (ONLY STRING DEFINED IN QUOTES ALLOWED) MAY BE SPECIFIED BEFORE ; THE VARIABLE LIST. ; ^THIS IS EQUIVALENT TO A R3 BIT #4000,-2(R3) ;IS BINARY CONTROL BIT SET BEQ 2$ ;IF NOT, SKIP FLAG SET BIS #2,LINEFL ;SET BINARY BIT 2$: JSR PC,COM00 ;GET VARIABLE BVC INP02 ;IT IS OK 3$: INPERR ;ISSUE FATAL ERROR INP02: MOV R1,-(SP) ;SAVE THE TEXT POINTER INP10: CMP #TINPT,INPT ;IS THIS TERMINAL INPUT?? BNE INP07 ;SKIP PROMPT IF NOT TSTB PRMTFL ;PROMPT MODE SET? BEQ INP07 ;IF NOT, BRANCH MOV #'?,R2 ;TELL HIM TO GET WITH IT PRINTC INP07: PACK ;GET A LINE JSR PC,FILL00 ;TRY TO SATISFY THE REQUEST BVS INP06 ;OVERFLOW IS BAD DATA BGT INP04 ;TOO MUCH INPUT TYPED BLT INP05 ;NOT ENOUGH INPUT TYPED MOV (SP)+,R1 ;RECOVER THE TEST ADDRESS MOV (SP)+,R5 ;INPUT LIST POINTER -> R5 MOV R5,SP ;THIS IS WHERE STACK USED TO BE ADD #2,SP ;(ALMOST) DEC R1 ;BACK UP CHARACTER POINTER CLR LINEFL ;BACK TO NORMAL INPUT TST RUNF ;CHECK FOR IMMEDIATE MODE BNE INP03 ;OMIT THIS LITTLE BIT IF RUNNING MOVB #S.EOL2,(R1) INP03: JMP INIT02 INP04: IN1ERR ;HE TYPED TOO MUCH BR INP10 ;TRY AGAIN INP05: IN2ERR ;HE DIDN'T TYPE ENOUGH BR INP10 ;TRY AGAIN INP06: IN3ERR ;HE IS A LOUSY TYPIST BR INP10 ;TRY AGAIN ; ; STRCMP - STRING COMPARISON ROUTINE ; ON CALL: ; R3 CONTAINS ADDRESS OF FIRST STRING ; R2 CONTAINS ADDRESS OF SECOND STRING ; R4 CONTAINS LEN FOR COMPARISON STRCMP: TST R4 ;IS LEN ZERO? BEQ 3$ ;IF SO, DONE 4$: CMPB (R3)+,(R2)+ ;CHARACTERS EQUAL? BNE 3$ ;IF NOT, RETURN AS FAILED SOB R4,4$ ;KEEP GOING TILL DONE 3$: RTS PC .SBTTL FILL00 - COMMON DATA ELEMENT FILL ROUTINE ; ; ON ENTRY: ; R1 POINTS TO START OF DATA ; LINELN HAS LENGTH OF DATA FOR BINARY OR INPUT LINE ; STACK AS ON EXIT FROM COM00 PLUS TEXT PTR AND SUBROUTINE LINK ; ; ON EXIT: ; R1 POINTS PAST END OF DATA USED (TO EOL CHAR IF ASCII) ; LINELN = REMAINING CHAR COUNT (USUALLY 0) ON BINARY ; 'V' SET ON BAD DATA (ASCII ONLY) ; BGT TRUE IF TOO MUCH DATA (ASCII ONLY) ; BLT TRUE IF NOT ENOUGH DATA (ASCII AND BINARY NUMERIC) ; ; NOTE: CONDITION CODES ONLY RELEVANT FOR ASCII DATA AND BINARY NUMERIC ; ; OTHER REGISTERS USED: R0 THROUGH R5, AC0 AND AC1 ; FILL00: MOV 4(SP),R5 ;START OF LIST ADDRESS -> R5 FILL01: 3$: JSR PC,FILL1 ;DO INDIVIDUAL ITEM BVS 99$ ;ON ERROR BRANCH BLT 99$ ;ALSO BRANCH IF NOT ENOUGH DATA SUB #10,R5 ;POINT TO NEXT ITEM TST (R5) ;ANOTHER ITEM? BEQ 4$ ;IF NOT, BRANCH TST LINEFL ;DOING BINARY OR INPUT LINE? BNE 2$ ;IF SO, BRANCH CMPB (R1),#', ;DO WE HAVE NEEDED COMMA? BEQ 1$ ;IF SO, BRANCH CMPB (R1),#S.EOL2 ;AT END? BNE 3$ ;IF NOT, GO AROUND AGAIN 5$: CCC ;ELSE SET LESS THAN CONDITION SEN BR 99$ ;AND EXIT 1$: INC R1 ;PUSH PAST TERMINATOR BR 3$ ;AND GO AROUND AGAIN 2$: TST LINELN ;ANYTHING LEFT? BNE 3$ ;IF SO, GO AROUND AGAIN BR 5$ ;ELSE GO SET LESS THAN (NOT ENOUGH DATA) ; ; COME HERE IF NO MORE ITEMS TO FILL ; 4$: TST LINEFL ;DOING BINARY OR INPUT LINE? BNE 98$ ;IF SO, BRANCH (EXCESS IS OK) CMPB (R1),#S.EOL2 ;AT END OF LINE? BEQ 98$ ;IF SO, BRANCH TO SUCCESSFUL EXIT CCC ;SETS GREATER THAN CONDITION (TOO MUCH DATA) 99$: RTS PC ;RETURN WITH ERROR CONDITION SET 98$: CLR R0 ;SET 'Z' (SUCCESS) RTS PC ; ; INDIVIDUAL ITEM FILL PROCESSOR ; ; ON ENTRY: ; R5 POINTS TO 4 WORD ITEM DESCRIPTOR ON STACK ; R1 HAS START OF TEXT WITH INPUT INFO ; ; ON EXIT: ; R5 AS ABOVE ; R1 POINTS PAST END OF THIS ITEM'S TEXT ; ; OTHER REGISTERS USED: ; FILL1: CMP -2(R5),#10 ;DO WE HAVE STRING? BEQ 20$ ;IF SO, BRANCH TST LINEFL ;STRAIGHT FILL OR CONVERSION? BNE 1$ ;IF STRAIGHT (BINARY), BRANCH ATOF ;ELSE CONVERT NUMBER BVS 99$ ;ON ERROR, BRANCH SKIP ;SKIP OVER ANY TERMINATING BLANKS DEC R1 ;AND POINT TO FIRST NON-BLANK BR 8$ ;GO TO STORE CODE 1$: BIT #1,LINEFL ;DOING INPUT LINE? BNE 98$ ;IF SO, ERROR MOV -2(R5),R0 ;DATA TYPE -> R0 ASR R0 ;DIVIDE BY TWO MOVB 10$(R0),R2 ;# OF STACK BYTES NEEDED -> R2 SUB R2,SP ;GET US THE ROOM ON THE STACK MOVB 11$(R0),R2 ;GET # BYTES FOR XFER -> R2 SUB R2,LINELN ;ADJUST LINE LENGTH BLT 9$ ;IF NOT ENOUGH INPUT, BRANCH MOV SP,R3 ;ADDRESS FOR XFER -> R3 2$: MOVB (R1)+,(R3)+ ;TRANSFER IN SOB R2,2$ ;BINARY INFO ASL R0 ;BACK TO ORIGINAL VALUE JMP @3$(R0) ;AND GO TO PROPER CODE 3$: .WORD 4$ ;REAL*4 .WORD 5$ ;INTEGER .WORD 6$ ;BYTE .WORD 7$ ;REAL*8 4$: LDF (SP)+,AC0 ;REAL VALUE -> AC0 BR 8$ ;GO TO FINISH 5$: LDCIF (SP)+,AC0 ;INTEGER -> AC0 BR 8$ ;GO TO FINISH 6$: MOVB (SP),R2 ;INTEGER VALUE FROM BYTE TST (SP)+ ;CLEAN STACK LDCIF R2,AC0 ;AND INTEGER -> AC0 BR 8$ ;GO TO FINISH 7$: LDCDF (SP)+,AC0 ;CONVERT DOUBLE TO FLOATING 8$: MOV (R5),R3 ;DATA ITEM HEADER -> R3 LDF -6(R5),AC1 ;OFFSET -> AC1 JSR PC,STONUM ;STORE NUMBER RTS PC ;AND RETURN 9$: ADD R2,SP ;CLEAN STACK RTS PC ;AND RETURN WITHOUT CHANGING VALUE 10$: .BYTE 4,2,2,10 ;# BYTES NEEDED FOR STACK 11$: .BYTE 4,2,1,10 ;# BYTES NEEDED FOR XFER ; ; STRING SECTION ; 20$: MOV (R5),R0 ;DATA ITEM HEADER -> R0 BIT #10000,(R0) ;VIRTUAL? BNE 22$ ;IF SO, BRANCH MOVB 4(R0),R4 ;LENGTH -> R4 BIC #177400,R4 ;CLEAR ANY SIGN EXTEND TST 4(R0) ;IS THIS VARIABLE LENGTH BGE 21$ ;IF NOT, BRANCH NEG R4 ;IF SO, MAKE IT NEGATIVE FOR FURTHER PROCESSING 21$: BR 23$ ;BRANCH AROUND VIRTUAL CODE 22$: MOV 10(R0),R4 ;GET VIRTUAL ITEM LENGTH -> R4 23$: MOV R1,R3 ;SET START OF STRING -> R3 TST LINEFL ;INPUT LINE OR BINARY? BNE 30$ ;IF SO, BRANCH ;ELSE REGULAR ASCII INPUT TST R4 ;FIXED OR VAR? BPL 26$ ;IF FIXED, BRANCH ; ; ASCII INPUT, VARIABLE LENGTH ; CLR R4 ;START WITH ZERO LENGTH STRING 24$: MOVB (R1)+,R2 ;NEXT CHAR -> R2 CMPB R2,#', ;IS IT COMMA? BEQ 25$ ;IF SO, BRANCH CMPB R2,#S.EOL2 ;END OF LINE? BHIS 25$ ;IF SO, ALSO BRANCH INC R4 ;ELSE IT'S A GOOD CHARACTER BR 24$ ;SO ADD 1 AND KEEP COUNTING ; ; ASCII INPUT, FIXED STRING LENGTH ; 26$: MOV R4,-(SP) ;SAVE LENGTH 27$: MOVB (R1)+,R2 ;NEXT CHAR -> R2 CMPB R2,#', ;LOOK FOR COMMA BEQ 29$ ;IF SO, END OF STRING CMPB R2,#S.EOL2 ;OR COULD BE END OF LINE BHIS 29$ ;IF FOUND, BRANCH SOB R4,27$ ;KEEP LOOKING FOR WHOLE STRING LENGTH 28$: MOVB (R1)+,R2 ;AND LOOK FOR TERMINATOR OF STRING CMPB R2,#', ;EITHER COMMA BEQ 29$ CMPB R2,#S.EOL2 ;OR END OF LINE BEQ 29$ ;WHEN FOUND, GO TO COMMON FINISH BR 28$ ;KEEP GOING TILL IT'S FOUND 29$: SUB R4,(SP) ;REDUCE LENGTH STORED ON STACK MOV (SP)+,R4 ;AND POP ADJUSTED LENGTH -> R4 25$: DEC R1 ;BACK UP TEXT PTR TO TERMINATOR BR 32$ ;AND BRANCH TO STORAGE SECTION ; ;BINARY (OR INPUT LINE) FIXED AND VARIABLE ; 30$: TST R4 ;MAKE SURE BPL 33$ ;LENGTH IS POSITIVE NEG R4 33$: CMP R4,LINELN ;DO WE HAVE ENOUGH BYTES BLE 31$ ;IF SO, BRANCH MOV LINELN,R4 ;ELSE USE JUST WHAT'S LEFT 31$: SUB R4,LINELN ;ADJUST REMAINING LENGTH 32$: MOV (R5),R0 ;SET UP R0 (DATA ITEM ADDRESS) LDF -6(R5),AC0 ;AND OFFSET JSR PC,STOSTR ;STORE IT CCC ;MAKE SURE EVERYTHING LOOKS OK 99$: RTS PC ;AND RETURN 98$: INPERR .SBTTL COM00 - COMMON EXPRESSION HANDLER FOR READ AND INPUT ; ; ON ENTRY: ; R1 IS TEXT PTR ; ; ON EXIT: ; R1 POINTS PAST END OF STATEMENT ; 'V' SET IF ERROR IN VARIABLE LIST ; STACK ON EXIT: ; DATA PTR (1 WORD) ; DATA TYPE (1 WORD) ; OFFSET (2 WORDS) ; DATA PTR ; DATA TYPE ; OFFSET ; . ; . ; . ; NULL ; SP -> PTR TO START OF LIST ; ; OTHER REGISTERS USED: POTENTIALLY ALL (INCL FLOATING PT.) ; COM00: LDCIF SP,AC2 ;MARK WHERE START OF LIST WILL BE LDCIF (SP)+,AC3 ;SAVE RETURN ADDRESS STF AC3,AC5 ;AND MOVE BOTH ITEMS STF AC2,AC4 ;OUT OF THE WAY CLR R2 ;IN CASE OF ERROR 3$: JSR PC,GETHDR ;GET HEADER AND TYPE BVS 5$ ;ON ERROR, BRANCH BNE 1$ ;IF DEFINED, BRANCH JSR PC,NEWVAR ;ELSE DEFINE IT 1$: BIT #1,LINEFL ;INPUT LINE IN PROGRESS? BEQ 2$ ;IF NOT, BRANCH CMP R0,#10 ;IF SO, DO WE HAVE STRING? BNE 5$ ;IF NOT, ERROR 2$: CLR -(SP) ;SPACE FOR HEADER ADDRESS MOV R0,-(SP) ;SAVE DATA TYPE JSR PC,GTOFFS ;GET OFFSET FOR VARIABLE MOV R3,2(SP) ;STORE HEADER ADDRESS STF AC0,-(SP) ;AND OFFSET SKIP ;NEXT CHAR -> R2 CMPB R2,#', ;COMMA? BEQ 3$ ;IF SO, GO AROUND AGAIN 5$: CLR -(SP) ;SET LIST END MARKER LDF AC4,AC2 ;LET'S GET BACK START OF LIST LDF AC5,AC3 ;AND RETURN ADDRESS STCFI AC2,-(SP) ;CONVERT START TO INTEGER STCFI AC3,-(SP) ;AND ALSO RETURN ADDRESS ON STACK JSR PC,EOSCHK ;END OF STATEMENT? BEQ 4$ ;IF SO, BRANCH SEV ;ELSE SET ERROR CODE 4$: RTS PC ;AND RETURN ; ; ROUTINE EOSCHK ; TO CHECK FOR LEGIT END OF STATEMENT ; ; ON ENTRY: ; R2 HAS CHAR TO BE CHECKED ; ; ON EXIT: ; 'Z' SET IF END ; 'Z' CLEAR IF NOT END CHAR ; ; OTHER REGISTERS USED: NONE ; EOSCHK: CMPB R2,#S.EOS1 ;END OF STATEMENT PROPER? BHIS 1$ ;IF SO, SUCCESS (BRANCH) CMPB R2,#S.ELSE ;AN ELSE TOKEN? BEQ 1$ ;IF SO, ALSO END CMPB R2,#S.EXC ;COMMENT? BEQ 1$ ;IF SO, ALSO END CCC RTS PC ;RETURN WITH NO COND. CODES SET 1$: CCC SEZ ;INDICATE SUCCESS (END OF STATEMENT) RTS PC ;AND RETURN .SBTTL READ00 - READ STATEMENT PROCESSOR ;+3 ; .SKIP ; .X ^^READ\\ ; .X ^^DATA\\ ; .INDENT -5 ; ^^ ; READ ; .INDENT -5 ; DATA ; \\ ; .BREAK ; ^THE ^^READ\\ STATEMENT INPUTS DATA FROM THE ^^DATA\\ STATEMENT. ; ^THE RULES FOR ^^INPUT\\ APPLY TO ^^READ\\, BUT ^^DATA\\ LISTS ARE ; USED AS NEEDED WHEREAS ^^INPUT\\ INPUTS AN ENTIRE LINE FROM A FILE. ; .BREAK ; ^EXAMPLE: ; .NOFILL ; ^^ ; 10 DATA 10.5,-76,1E7,FRANK ; 50 READ A,B,C,D$ ; \\ ; .FILL ;- READ00: CLR LINEFL ;JUST IN CASE INPUT LINE WAS ^Z'ED JSR PC,COM00 BVC 2$ REAERR 2$: MOV (SP),R5 ;SET UP LIST POINTER MOV R1,-(SP) MOV DATI,R1 ;PICK UP THE CURRENT POINTER BNE 1$ ;START NOW IF WE ARE SOME WHERE MOV USR,R1 ;START FROM THE BEGINING BR 5$ ;AND LOOK FOR A DATA STATEMENT 1$: ADD USR,R1 ;MAKE OFFSET INTO REAL ADDRESS 3$: CMPB (R1),#S.EOL2 ;NEXT BEQ 5$ ;DATA STATEMENT CMPB (R1),#', ;AT A COMMA? BNE 4$ ;IF NOT, BRANCH INC R1 ;IF SO, PUSH PAST IT 4$: JSR PC,FILL01 ;GO GET DATA BVS 7$ ;OH NO AN ERROR BLT 5$ ;BRANCH ON NOT ENOUGH DATA SUB USR,R1 ;MAKE ADDRESS INTO OFFSET MOV R1,DATI ;SAVE THE POINTER FOR NEXT TIME MOV (SP)+,R1 ;GET BACK THE TEXT POINTER MOV (SP)+,R5 ;DATA ITEM LIST PTR -> R5 MOV R5,SP ;WHICH IS START OF OLD STACK ADD #2,SP ;IF YOU ADD 2 DEC R1 JMP INIT02 ;BACK TO THE BOSS 5$: MOV ENDTXT,R3 ;FIND THE UPPER LIMIT 6$: CMPB #S.DATA,(R1)+ ;IS WE AT A DATA STATEMENT?? BEQ 3$ ;IF SO GO FINISH WHAT WE STARTED CMP R1,R3 ;SEE IF IT'S ALL OVER BLO 6$ ;BRANCH IF MORE TEXT RE1ERR ;FATAL ERROR 7$: RE2ERR ;FATAL ERROR .SBTTL FOR00 - FOR STATEMENT ;+3 ; .SKIP ; .X ^^FOR\\ ; .INDENT -5 ; ^^ ; FOR ; \\ ; .BREAK ; .NOFILL ; ^FORMAT: ; ^^FOR _ = _ TO _ [STEP _]\\ ; .FILL ; ^THIS STATEMENT SETS UP AND CONTROLS EXECUTION OF A ^^FOR-NEXT\\ LOOP. ; ^ANY NUMERIC EXPRESSIONS MAY BE USED. ; ^THE VARIABLE MUST BE, HOWEVER, A SIMPLE FLOATING VARIABLE ; (NO SUBSCRIPT). ; ^THE STATEMENTS FOLLOWING THE ^^FOR\\ STATEMENT UNTIL THE ASSOCIATED ; ^^NEXT\\ STATEMENT COMPRISE THE LOOP. ; ^THE LOOP BEGINS WITH THE VARIABLE SET EQUAL TO ^^EXP1\\ AND ; CONTINUES BY INCREMENTING THE VARIABLE BY ^^EXP3\\ (DEFAULTED TO ONE) ; UNTIL IT REACHES OR PASSES THE VALUE OF ^^EXP2\\ (THEREFORE THE LOOP ; MAY NOT BE EXECUTED AT ALL). ; ^FINAL VALUE OF THE VARIABLE IS ITS VALUE THE LAST TIME THROUGH THE ; LOOP. ; ^NOTE: ^CHANGING THE VALUE OF THE VARIABLE WITHIN THE LOOP WILL ; AFFECT THE NUMBER OF TIMES THE LOOP IS EXECUTED. ; .BREAK ; ^EXAMPLE: ; .NOFILL ; ^^ ; 40 FOR I=1 TO 5.5 STEP .5 ; 100 FOR J1=-.1 TO -1.5 STEP -.1 ; \\ ; .FILL ;- ; REGISTERS USED - ALL. ; FOR00: JSR PC,GETHDR ;GET CONTROL VARIABLE HEADER BVS FOR99 ;ON ERROR, BRANCH BNE 1$ ;IF DEFINED ALREADY, BRANCH JSR PC,NEWVAR ;ELSE DEFINE IT 1$: SKIP ;GET NEXT CHAR CMPB R2,#'= ;IS IT EQUAL SIGN (SIMPLE VARIABLE ONLY) BNE FOR99 ;IF NOT, ERROR BIT #10000,(R3) ;IS IT VIRTUAL? BNE FOR99 ;ALSO ILLEGAL IF SO CLR -(SP) ;SET UP A SLOT ON STACK MOV R4,-(SP) ;AND SAVE VARIABLE HEADER DEC R1 ;BACK OFF TO EQUAL SIGN SO THE NEXT ;SUBROUTINE DOESN'T GET CONFUSED JSR PC,GTOFFS ;AND GET OFFSET (R0 HAS ADDRESS) SKIP ;NOW POINT TO NEXT NON-BLANK AFTER '=' FOR02: MOV R0,2(SP) ;SAVE DATA ADDRESS MOV (SP),R4 ;RESTORE VARIABLE HEADER JSR PC,SCHFOR ;SEE IF WE HAVE A CONTROL BLOCK BEQ FOR03 ;IF NOT, BRANCH JSR PC,DELFOR ;IF SO, GO DELETE IT FOR03: MOV #20,R0 ;CHECK FOR ROOM TSTOK BHIS 1$ ;IF OK, BRANCH OVFERR 1$: MOV STGOSB,R2 ;START OF BLOCK TO MOVE -> R2 MOV STFONX,R3 ;END OF BLOCK -> R3 JSR PC,SLDN ;SLIDE IT DOWN BY R0 BYTES SUB R0,STGOSB ;ADJUST POINTERS SUB R0,STFONX MOV STFONX,R3 ;R3 HAS START OF NEW CONTROL BLOCK MOV (SP)+,(R3) ;GET SIXBIT NAME FROM STACK TO CTRL BLOCK MOV (SP)+,R0 ;STORAGE ADDRESS FOR CTRL VARIABLE -> R0 MOV R0,6(R3) ;STORE IT AWAY SUB STUDAT,6(R3) ;AS OFFSET MOV LINENO,2(R3) ;SET UP LINE NUMBER MOV STCOUN,4(R3) ;AND STATEMENT COUNT MOV R3,-(SP) ;SAVE CTRL BLOCK ADDRESS MOV R0,-(SP) ;AND CTRL VARIABLE ADDRESS EVAL ;GET THE STARTING FORMULA MOV (SP)+,R0 ;DESTINATION STF AC0,(R0)+ ;PUT AWAY THE VALUE SKIP ;NEXT CHAR -> R2 CMPB R2,#S.TO ;IS IT 'TO' TOKEN BNE FOR99 ;NO EVAL ;YES STF AC0,-(SP) ;PUT ENDING VALUE AWAY SKIP ;GET NEXT CHAR CMPB R2,#S.STEP ;IS IT STEP? BEQ 2$ ;IF SO, BRANCH DEC R1 ;ELSE BACK UP LDCIF #1,AC0 ;SET DEFAULT STEP BR FOR04 ;AND SKIP EVALUATION OF STEP 2$: EVAL ;EVALUATE THE STEP VALUE FOR04: LDF (SP)+,AC1 ;GET ENDING VALUE MOV (SP)+,R3 ;RESTORE START OF CTRL BLOCK -> R3 STF AC1,14(R3) ;STORE ENDING VALUE STF AC0,10(R3) ;PUT THE STEP VALUE AWAY FOR06: JSR PC,CHKFOR ;GO CHECK IF AT END OF LOOP ALREADY BGE FOR12 ;IF NOT, GO EXECUTE MOV (R3),-(SP) ;SAVE SIXBIT VARIABLE NAME FOR FUTURE JSR PC,DELFOR ;DELETE FOR CONTROL BLOCK BR FOR09 ;AND GO LOOK FOR END OF LOOP FOR12: JMP INIT02 ;GO DO NEXT STATEMENT FOR99: FORERR FOR09: MOV BOLNHD,R3 ;SET UP TO LOOK IMMEDIATELY FOR END OF MOV LINEHD,R5 ;LOOP (FOR LOOP IS OVER BEFORE IT STARTS) FOR10: SKIP ;NEXT CHAR -> R2 CMPB R2,#S.NEXT ;IS IT A "NEXT"? BEQ FOR11 ;IF SO, GO LOOK AT IT JUNKIT ;IF NOT, SKIP REST OF STATEMENT CMPB (R1)+,#S.EOL2 ;END OF LINE? BNE 2$ ;IF NOT (JUST END OF STATEMENT), BRANCH SUB #4,R5 ;GET NEXT LINE HEADER -> R5 CMP R5,R3 ;PAST END? BHIS 1$ ;IF NOT, CONTINUE NXTERR ;IF SO, ERROR (FOR WITHOUT NEXT) 1$: MOV 2(R5),R1 ;START OF NEXT LINE -> R1 ADD USR,R1 ;ADD IN OFFSET MOV #1,STCOUN ;INIT STATEMENT COUNT BR FOR10 ;AND KEEP LOOKING 2$: INC STCOUN ;PUSH ON IN LINE BR FOR10 ;AND KEEP LOOKING FOR11: GETVAR CMP R4,@SP ;IS VARIABLE CORRECT? BNE FOR16 ; LOOP UNTIL FOUND OR FAILURE TST (SP)+ ;WE-UNS IS HERE BOSS FOR15: DEC R1 MOV R5,LINEHD ;UPDATE CURRENT LINE HEADER MOV (R5),LINENO ;AND LINE # BR FOR12 ;AND IS DONE FOR16: CMPB R2,#', ;LOOK FOR FORM: NEXT I,J BEQ FOR11 ;IF SO, TRY AGAIN BR FOR10 ;ELSE CONTINUE REGULAR SEARCH .SBTTL NEXT00 - NEXT STATEMENT TO TERMINATE FOR LOOP ;+3 ; .SKIP ; .X ^^NEXT\\ ; .INDENT -5 ; ^^ ; NEXT ; \\ ; .BREAK ; .NOFILL ; ^FORMAT: ; ^^NEXT _\\ ; .FILL ; ^THIS STATEMENT TERMINATES THE LOOP BEGUN BY THE ; IMMEDIATELY PRECEDING ^^FOR\\ STATEMENT ; WITH THE SAME VARIABLE NAME. ; ^A CONCATENATED FORM OF TWO AC1 SUBF AC0,AC1 ;TERM-NEW -> AC1 DIVF 10(R3),AC1 ;(TERM-NEW)/STEP -> AC1 CFCC ;COPY CONDITION CODES BMI NEXT01 ;IF PAST TERMINAL VALUE, BRANCH STF AC0,(R0) ;PUT BACK NEW VALUE MOV 2(R3),R0 ;LINE # -> R0 MOV 4(R3),-(SP) ;STATEMENT COUNT ON STACK FINDLN ;FIND WHERE IT BELONGS MOV (SP)+,R2 ;STATEMENT COUNT -> R2 JSR PC,STFIND ;FIND PLACE IN LINE (PRINT TRACE MESSAGE) JMP INIT03 ;AND CONTINUE IN INTERPRETER NEXT99: NXMERR ;NEXT WITHOUT FOR NEXT01: MOV R2,-(SP) ;SAVE NEXT CHAR JSR PC,DELFOR ;DELETE CTRL BLOCK CMPB (SP)+,#', ;IS NEXT CHAR A COMMA? BEQ NEXT00 ;IF SO, START CHECK OVER DEC R1 ;BACK UP TEXT PTR JMP INIT02 ;AND CONTINUE PROCESSING ; ; ROUTINE TO SEARCH FOR A GIVEN FOR/NEXT CTRL BLOCK ; ON ENTRY: ; R4 HAS SIXBIT NAME ; ; ON EXIT: ; R4 UNCHANGED ; 'Z' SET IF NOT FOUND, R3 = 0 ; 'Z' CLEAR IF FOUND, R3 = ADDRESS OF CTRL BLOCK ; ; OTHER REGISTERS USED: NONE ; SCHFOR: MOV STFONX,R3 ;START OF FOR/NEXT CTRL BLOCK AREA -> R3 1$: CMP R3,STUFDB ;AT END YET? BHIS 3$ ;IF SO, BRANCH CMP R4,(R3) ;IS THIS THE RIGHT ONE? BNE 2$ ;IF NOT, BRANCH CLZ ;IF SO, INDICATE SUCCESS RTS PC ;AND RETURN 2$: ADD #20,R3 ;ADD SIZE OF CTRL BLOCK BR 1$ ;SO WE POINT TO NEXT ONE AND LOOK AGAIN 3$: CLR R3 ;INDICATE FAILURE RTS PC ;AND RETURN ; ; ROUTINE TO DELETE A FOR/NEXT CTRL BLOCK ; ON ENTRY: ; R3 POINTS TO CTRL BLOCK TO BE DELETED ; ON EXIT: ; R3 UNDETERMINED ; OTHER REGISTERS USED: R0,R2 ; DELFOR: MOV STGOSB,R2 ;START OF BLOCK TO BE MOVED -> R2 MOV #20,R0 ;AMOUNT TO MOVE UP JSR PC,SLUP ;GO SLIDE IT UP ADD R0,STGOSB ;ADJUST PTRS ADD R0,STFONX RTS PC ; ; ROUTINE TO CHECK ON FINISHED/NOT FINISHED CONDITION ; OF FOR/NEXT LOOP. ; ON ENTRY: ; R3 POINTS TO FOR/NEXT CTRL BLOCK ; ON EXIT: ; R3 UNCHANGED ; 'Z' SET IF CTRL VARIABLE AT END VALUE, CLEAR OTHERWISE ; 'N' SET IF CTRL VARIABLE PAST END VALUE, CLEAR OTHERWISE ; R0 HAS ACTUAL STORAGE ADDRESS OF CONTROL VARIABLE ; REGISTERS USED: ; AC0 ; CHKFOR: LDF 14(R3),AC0 ;TERM VALUE -> AC0 MOV 6(R3),R0 ;OFFSET OF CTRL VARIABLE -> R0 ADD STUDAT,R0 ;MAKE IT ACTUAL ADDRESS SUBF (R0),AC0 ;TERM VALUE - CURRENT VALUE -> AC0 DIVF 10(R3),AC0 ;(TERM-CURRENT)/STEP -> AC0 CFCC ;COPY CONDITION CODES RTS PC ;AND RETURN .END ;