ASMB,R,Q,C HED <> 92076-16001 REV.2040 NAM BASIC,4,90 92076-16001 REV.2040 800727 LOD 2,SG,8 * * ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** * * * NAME: BASIC * SOURCE: 92076-18001 * RELOC: 92076-16001 * PGMR: B.J.L. * * ************************************************************* * ENT SGMNT,FINDV,ERRPT,DRQST,WDRQS,GETCR,OUTCR,BCKSP,LETCK ENT PRMT,REED,WRITE,PEXMK,RDYPT,OUTER,INTCK ENT DIGCK,FNDPS,OUTIN,ENOUT,NUMOT,GETDG ENT RPRCS,PRNIN,OUTLN,NUMCK,SSYMT,MVTOH,RUN,COMND ENT NORML,MBY10,DBY10,COMFL,PLIST,LOADT,.IENT,OLNCK EXT REIO,.FLUN,EXEC,READF,WRITF * EXT ..FCM,.PACK,BASC1 EXT OLY.C,LOGLU,GETST,NAMR COM TEMPS(32),PNTRS(81),FILBF(16),FLDCB(144),SPEC(10) * INCREASED PNTRS FOR NEW TRAP FLAG TO INDICATE BUSY TABLE 800727 * * UPDATED SEG. 3 AND 5 FOR L20 800627 * *TEMPS INCREASED TO 32 800107********************** *REMOVED ROUTINES RETCR,RMPAR 790817************** *PNTRS INCREASED TO 79 790830******************** *PNTRS INCREASED TO 80 791010******************** * ************************************** * * * BASIC MAIN CONTROL * * * ************************************** * * THIS PART OF THE INTERPRETER REMAINS CORE RESIDENT DURING * THE EXECUTION OF BASIC. IT INTERPRETS AND EXECUTES ALL * OF THE SYSTEM COMMANDS BY LOADING THE APPROPRIATE SEGMENT * AND TRANSFERRING EXECUTION TO IT. UPON COMPLETION, THE * SEGMENTS RETURN EXECUTION TO THIS PROGRAM.IN ADDITION, IT * PROVIDES FOR ALL USER COMMUNICATION WITH THE INTERPRETER. * THERE ARE 8 SEGMENTS WHICH MAY CALLED BY THE MAIN CONTROL: * * SEGMENT #1: CHECKS SYNTAX AND TRANSLITERATES CODE * SEGMENT #2: LISTS THE PROGRAM * SEGMENT #3: CHECKS THE PROGRAM PRIOR TO EXECUTION * SEGMENT #4: EXECUTES THE PROGRAM * SEGMENT #5: EXECUTES COMMANDS * SEGMENT #6: EXECUTES MORE COMMANDS * SEGMENT #7: EXECUTES DEBUG COMMANDS * SEGMENT #8: EXECUTES NON-TIME DEPENDENT STATEMENTS * * * TO RUN BASIC USE: * * :RU,BASIC * * OR * * * :RU,BASIC,NAMEXX:SC:CR * * WHERE: NAMEXX = THE COMMAND FILE NAME * SC = SECURITY CODE * CR = CARTRIDGE REFERENCE NUMBER * *************************** * * * CONSTANTS AND VARIABLES * * * *************************** * FWAM EQU PNTRS FIRST WORD OF AVAILABLE MEMORY LWBM EQU PNTRS+1 LAST WORD OF AVAILABLE MEMORY .INBF EQU PNTRS+2 INPUT BUFFER ADDRESS SBUFA EQU PNTRS+3 SYNTAX BUFFER ADDRESS SYMTA EQU PNTRS+4 START OF SYMBOL TABLE SYMTF EQU PNTRS+5 END OF SYMBOL TABLE PBUFF EQU PNTRS+6 FIRST WORD OF USER PROGRAM PBPTR EQU PNTRS+7 LAST WORD+1 OF USER PROGRAM INBFA EQU PNTRS+8 INPUT BUFFER POINTER ICCNT EQU PNTRS+9 INPUT CHARACTER COUNT SBPTR EQU PNTRS+10 SYNTAX BUFFER POINTER .LNUM EQU PNTRS+11 CURRENT LINE # FCORE EQU PNTRS+12 START OF FREE CORE MNNAM EQU PNTRS+13 MNEMONIC TABLE NAME:SC:LU BRNAM EQU PNTRS+18 BRANCH TABLE NAME:SC:LU FWAMM EQU PNTRS+23 POINTER TO START OF MNEMONIC TABLE FWAMB EQU PNTRS+24 POINTER TO START OF BRANCH TABLE .OTBF EQU PNTRS+25 POINTER TO OUTPUT BUFFER OCCNT EQU PNTRS+26 OUTPUT CHARACTER COUNT OTBFA EQU PNTRS+27 POINTER INTO OUTPUT BUFFER LUOUT EQU PNTRS+28 CURRENT OUTPUT L.U. # LUINP EQU PNTRS+29 CURRENT INPUT L.U. # SIGN EQU PNTRS+30 SIGN OF CURRENT NUMBER BLANK EQU PNTRS+31 CURRENT TERMINATION CHAR REC# EQU PNTRS+32 COMMAND FILE RECORD NUMBER FLTYP EQU PNTRS+33 TYPE 0 FILE FLAG ********CHANGED FOR L USAGE OF GETST 790409****** TTYPR EQU PNTRS+34 CONSOLE LU# OR FILENAME TTYP1 EQU PNTRS+35 3RD AND 4TH CHAR TTYP2 EQU PNTRS+36 5TH AND 6TH CHAR TTYP3 EQU PNTRS+37 SECURITY CODE FOR FILE TTYP4 EQU PNTRS+38 CRN # OF FILE ************************************************************* DCB EQU PNTRS+39 DATA CONTROL BLOCK ADDRESS FILBK EQU PNTRS+40 FILE CONTROL BLOCK ADDRESS PFLAG EQU PNTRS+41 SAVE,LOAD FILE FLAG LOLIM EQU PNTRS+42 LOW LIMITS OF PROGRAM HILIM EQU PNTRS+43 HIGH LIMITS OF PROGRAM LORUN EQU PNTRS+44 LOW RUN LIMITS HIRUN EQU PNTRS+45 HIGH RUN LIMITS SLSTM EQU PNTRS+46 EXECUTE SLOW STMTS LOTRC EQU PNTRS+47 LOW TRACE LIMITS HITRC EQU PNTRS+48 HIGH TRACE LIMITS BRKP1 EQU PNTRS+49 BREAK POINT #1 BRKP2 EQU PNTRS+50 BREAK POINT #2 BRKP3 EQU PNTRS+51 BREAK POINT #3 BRKP4 EQU PNTRS+52 BREAK POINT #4 SMFLG EQU PNTRS+53 SIMULATE FLAG TYPE EQU PNTRS+54 PARTIAL LINE CHARACTER COUNT DLMTR EQU PNTRS+55 CHAR EDIT DELIMITER MERGF EQU PNTRS+56 MERGE FLAG ***********************790712************************************* COMN EQU PNTRS+57 COMMAND FILE NAME:SC:CRN MANT1 EQU PNTRS+62 MANTISSA #1 MANT2 EQU PNTRS+63 MANTISSA #2 EXPNT EQU PNTRS+64 EXPONENT ************************CHANGED 790830****************************** ************************CHANGED 791010****************************** INNAM EQU PNTRS+65 NAME RTN. FROM CRETS (3 WORDS) INNUM EQU PNTRS+68 SCRATCH FILE # AND COUNTER HSTPT EQU PNTRS+69 HIGH-STACK POINTER TSTPT EQU PNTRS+70 TEMPORARY STACK POINTER LSTPT EQU PNTRS+71 LOW-STACK POINTER LSTAK EQU PNTRS+72 LOW-STACK ADDRESS PRADD EQU PNTRS+73 PROGRAM EXECUTION DSTRT EQU PNTRS+74 DATA NXTDT EQU PNTRS+75 STATEMENT DCCNT EQU PNTRS+76 POINTERS NXTST EQU PNTRS+77 NEXT STMT ********MOVED FROM BEHIND TTYPR FOR L 790409********** PRINT EQU PNTRS+78 LISTING LU# ERTTY EQU PNTRS+79 ERROR LU# TRAPF EQU PNTRS+80 TRAP BUSY FLAG *800727** *************************790830************************************** *READR NOP ****REMOVED 790828***** *PUNCH NOP ***REMOVED 790828*** ********************************************************************* SYFLG BSS 1 SYNTAX SEGMENT FLAG TEMPT BSS 15 BUFR BSS 40 *******ADD FOR L 790411***** ISTRC BSS 1 *******ADD FOR L 790411****** * RDYA DEF READY QMRKA DEF QMARK ACKNA DEF ACKNW POINT DEF TEMPT ********ADD FOR L 790411****** PNTLU DEF TTYPR ********ADD FOR L 790411****** SPC 1 SUP PRESS MULTIPLE LISTING SPC 1 .1 DEC 1 .2 DEC 2 .3 DEC 3 .4 DEC 4 .5 DEC 5 .6 DEC 6 .7 DEC 7 **ADDED 790829***** *.8 DEC 8 ********REMOVED 790817******* .9 DEC 9 *.12 DEC 12 *********REMOVED 790817********* .15 DEC 15 .26 DEC 26 .32 DEC 32 .36 DEC 36 .39 DEC 39 .40 DEC 40 ***ADD FOR BUG 790928 MM*** .43 DEC 43 .45 DEC 45 .46 DEC 46 .48 DEC 48 .49 DEC 49 .58 DEC 58 .66 DEC 66 ***ADD FOR BUG 790928 MM*** .80 DEC 80 .81 DEC 81 ***ADD FOR BUG 790928 MM*** .132 DEC 132 ***ADD FOR BUG 790928 MM*** .9999 DEC 9999 B77 OCT 77 E OCT 105 B177 OCT 177 B200 OCT 200 B377 OCT 377 ***ADDED 790822******* B400 OCT 400 MSK0 OCT 377 *B700 OCT 700 *****REMOVED 790817******* TENTH OCT 63146 RCODE OCT 100001 WCODE OCT 100002 HIMSK OCT 174000 *MSK OCT 177400 ********REMOVED 790817****** M1 DEC -1 M2 DEC -2 M3 DEC -3 *********ADD FOR L 790411******** M4 DEC -4 M5 DEC -5 M6 DEC -6 M7 DEC -7 M8 DEC -8 *9 DEC -9 *******REMOVED 790817****** M14 DEC -14 M80 DEC -80 D72 OCT -72 M132 DEC -132 ***ADD FOR BUG 790928 MM*** M256 DEC -256 D133 OCT -133 M1000 DEC -1000 M2000 DEC -2000 *****ADDED FOR L 790604*** M2001 DEC -2001 *****ADDED 800318** MSK3 EQU M7 B EQU 1 *M20K OCT -20000 ***REMOVED 790817****** *DUMY NOP ****REMOVED 790817****** ILOG NOP *********ADD FOR L 790411******* * QMARK ASC 1,?_ : ACKNW ASC 1,>_ : READY OCT 6412 ASC 6,BASIC READY SEG ASC 3,BASC SGMSK OCT 30040 HOLD NOP HOLD1 NOP ***************REMOVED FOR L 790529******* * SEG# DEC -9 ******************************************* ERBUF DEF *+1 ASC 19,SEGMENT NOT FOUND. BASIC TERMINATED! ERLEN DEC -38 SKP ********************** * * * BASIC MAIN CONTROL * * * ********************** BASIC NOP ENTRY * ******L USAGE OF GETST 790411******* JSB GETST FETCH RUN STRING IF ANY DEF GOON UNIT NUMBERS DEF BUFR BUFR OF 40 WORDS DEF M80 LENGTH IN -CHARS FOR NAMR DEF ILOG TRANS. LOG 790712 GOON JSB LOGLU GET LOG ON DEVICE DEF *+2 DEF HOLD1 DUMMY PLACE HOLDER STA PRINT LU RETURNED IN A REG. *NOTE: DON'T NEED ECHO BIT SET FOR OUTPUT DEVICE * 'PRINT' WILL BE USED IN SEG 3 TO DETERMINE * IF A COMMAND NAMR IS BEING USED. * IOR B400 SET ECHO BIT STA TTYPR CONSOLE LU# STA ERTTY SET TERM. LU = ERTTY *PUNCH AND READER NOT SETUP SINCE ERROR WILL BE ISSUED IF NO *LU OR FILE NAME IS ENTERED ON A COMMANDS EXCEPT 'LIST' AND 'RUN' * LDA ILOG CHECK FOR COMMAND NAMR SZA,RSS IF ILOG=0, NO COMMAND FILE JMP REST LDA .1 INITIALIZE ISTRC TO 1 STA ISTRC JSB NAMR CALL THE NAMR ROUTINE TO PARSE THE COMMAND DEF REST1 NAMR. WILL BE MOVED TO THE 5 WORDS DEF TEMPT IN COMMON OF TTYPR. TEMPT IS 15 WORDS DEF BUFR NEED ONLY 10 BUT WILL USE TEMPT. BUFR DEF ILOG SAME AS GETST AND ILOG # OF CHARS (+). DEF ISTRC VARIABLE FOR LOCATION COUNTER. INITIALLY =1. REST1 LDA POINT,I MOVE NAMR FROM TEMPT TO TTYPR AREA (3 WORDS) STA PNTLU,I POINT = TEMPT PNTLU = TTYPR ISZ POINT ISZ PNTLU ********************CHANGED 790928********************************* ISZ M3 JMP REST1 ISZ POINT MOVE TO WORD 5 OF TEMPT FOR SECURITY CODE LDA POINT,I STA PNTLU,I AND STORE IN TTYPR WORD 4 ISZ POINT ISZ PNTLU LDA POINT,I PICK UP CRN # AND STORE IN WORD 5 OF TTYPR STA PNTLU,I ***********************790928**************************************** ******************************************************************** REST LDA .9999 SET FLAG TO STA PFLAG TO ENABLE BASIC INIT. *************************REMOVED 790904****************************** * CLA CLEAR INVOKE * STA INLOC FLAG FIRST TIME *************************************790904************************** ********REMOVED FOR L 790409**************************************** * LDA $OPSY IF RTE-4, THEN USE NEW GMS.C FOR FWAM AND LWAM * CPA M9 LENGTHS FOR LARGEST SEGMENT AND * RSS 2ND LARGEST SEGMENT FWAM'S * JMP LDB3 ******************************************************** CLA CLEAR OUT FWAM AND FWAMM STA FWAM LARGEST FWAM STA FWAMM 2ND LARGEST FWAM *********REMOVED FOR L 790529************** * BASCI ISZ SEG# NEG. SEGMENT COUNT (INIT. AT -9) * RSS STILL SOME LEFT * JMP LDB3 DONE! * LDB SEG# GET SEGMENT # AND SET POS. * CMB,INB * CPB .3 WANT TO DO SEG. 3 LAST SINCE IT IS TRUE * JMP BASCI INITIALIZATION SEGEMENT * JMP SGMNT GO LOAD SEGMENT AND GET FWAM AND LWAM * ROTAT STA HOLD RET. HERE WITH A=FWAM B=LWAM * CMA,INA NEGATE FOR TESTING * STA HOLD1 * ADA FWAM IS THIS LARGEST? * SSA * JMP FINI YES, REPLACE CURREST FWAM WITH NEW * LDA HOLD1 IS THIS SECOND LARGEST? * ADA FWAMM * SSA,RSS * JMP BASCI NO, GET NEXT SEGMENT * LDA HOLD YES, REPLACE CURRENT FWAMM WITH NEW * STA FWAMM * JMP BASCI GET NEXT SEGMENT * FINI LDA FWAM MOVE LARGEST TO 2ND LARGEST * STA FWAMM * LDA HOLD REPLACE CURRENT FWAM WITH NEW * STA FWAM * STB TEMP1 AND SAVE THE ASSOCIATED LWAM * JMP BASCI GO GET NEXT SEGMENT ****************790529******************************************* LDB .3 GO TO SEG #3 TO INITIALIZE BASIC SPC 1 SGMNT BLF,BLF LOAD ALL BASIC SEGMENTS HERE ADB SGMSK STB SEG+2 JSB OLY.C OVERLAY ROUTINE FROM COMPILER LIB. DEF SEG ISZ FLTYP LDA TTYPR AND MSK0 CPA TTYPR RSS CLA,INA STA LUOUT LDA ERLEN HERE IF SEGMENT NOT FOUND BY OLY.C LDB ERBUF PRINT MESSAGE AND TERMINATE JSB WRITE JMP BYE SPC 1 RDYPT LDA TTYPR SET UP STA LUOUT INPUT AND STA LUINP OUTPUT DEVICE UNITS *****************************ADDED 790904***************************** CLB RESET INVOKE SC FILE # STB INNUM *****************************790904************************************* LDA M14 PRINT LDB RDYA THE BASIC'S 'NAME' JSB WRITE AND 'READY' JMP PRMT PROMPT! SPC 1 * EXECUTION RETURNED HERE FROM SEGMENT #1 SPC 1 * * PFLAG MAY HAVE THE FOLLOWING VALUES: * * PLFAG = -1 INPUT FROM TAPE * PFLAG = 0 INPUT FROM KEYBOARD * PFLAG = 1 INPUT FROM PROGRAM FILE * PFLAG = 2 INPUT FROM 'CHAIN' OR 'INVOKE' STATEMENT * PFLAG = 3 LOAD B&M TABLE FLAG * PFLAG = 4 INPUT FROM COMMAND FILE * PFLAG = 5 RUN A PROGRAM BY NAME * PFLAG = 9999 EXECUTE INITIALIZATION IN SEG 3(ONCE ONLY) * PEXMK LDA PFLAG CPA .1 FILE? JMP LOADF YES! CPA .2 CHAIN? JMP LOADF YES! CPA .5 RUN ? JMP LOADF YES! **********REMOVED FOR L 790529**************** * SZA IS TAPE FLAG SET? * JMP MORTP GET RECORD FROM PHOTO RDR *************790529************** * * EXECUTION RETURNED HERE FROM SEGMENTS #5 AND #6 * PRMT LDA TTYPR INITIALIZE STA LUOUT INPUT AND STA LUINP OUTPUT DEVICES UNITS CLA,INA INITIALIZE STA LOLIM LOW LIMIT STA LORUN LDA .9999 INITIALIZE STA HILIM HIGH LIMIT STA HIRUN CLA STA SLSTM CLEAR SLOW STMT FLAG STA DRQST CLEAR DATA REQUEST FLAG STA PFLAG CLEAR TAPE INPUT FLAG STA SYFLG CLEAR SYNTAX SEGMENT FLAG STA MERGF CLEAR OUT MERGE FLAG CCA SET FOR STA FLTYP NO TYPE 0 I-O LDA REC# ARE WE IN CPA .1 COMMAND FILE? RSS NO! JMP COMFL YES,CONTINUE LDA M2 LDB ACKNA JSB WRITE PRINT '>' WITH NO CR-LF JMP GTRCD INPUT RECORD SPC 1 * WARNING DATA INDICATION-PRINTS EXTRA QUESTION MARK SPC 1 WDRQS NOP LDA LUINP AND B77 STRIP OFF CONTROL BITS JSB FINDV IS IT A TERMINAL TYPE DRIVER? **************CHANGED 790829************************************ CMA,INA CHECK FOR TERMINAL DEVICE TYPE ADA .7 MUST BE <= 7 SSA JMP WDRQS,I TYPE >7 * SZA,RSS DVR00? * JMP QMK YES, PRINT QUESTION MARK! * CPA .5 DVR05? * RSS YES * JMP WDRQS,I NO! * SZB SC=0(KEYBD)? * JMP WDRQS,I NO! LDA M2 OUTPUT TYPE <=7 *******************************790829**************************** LDB QMRKA JSB WRITE '?' AND WAIT JMP WDRQS,I RETURN SPC 1 * PROCESS DATA REQUEST SPC 1 DRQST NOP LDA FLTYP TYPE 0 FILE? SZA,RSS JMP GTRCD YES! JSB WDRQS PRINT QUESTION MARK! SPC 1 * INPUT RECORD FROM TTY SPC 1 GTRCD LDA M80 LDB .INBF JSB REED GET RECORD FROM IT SPC 1 * PROCESS RECORD SPC 1 RPRCS CMA SET A = -1# CHARS STA ICCNT SET CHAR COUNT STA TEMP8 SET FOR ERROR PRINT OUT LDB .INBF LOAD BUFFER ADDRESS CLE,ELB SHIFT LEFT,LEAST BIT USED AS STB INBFA ODD/EVEN FLAG SZA,RSS NULL RECORD ? JMP GTRCD YES, INPUT AGAIN LDB DRQST SZB,RSS DATA REQUEST? JMP RPRC0 NO DATA REQUEST,GO CHECK RECORD CLA STA DRQST CLEAR DATA REQUEST FLAG JMP 1,I AND FAKE THE RETURN THRU DRQST SPC 1 * LOAD SYNTAX SEGMENT AND BRANCH TO IT SPC 1 RPRC0 JSB GETCR GET FIRST CHARACTER JMP GTRCD UNLESS THERE ISN'T ONE CKRCD LDB SBUFA INITIALIZE SYNTAX STB SBPTR BUFFER POINTER STA 1,I PUT FIRST CHAR IN SYNTAX BUFFER CPA DLMTR LIST NEXT LINE COMMAND? JMP COMND YES, LIST IT! JSB LETCK IS THIS A LETTER? RSS NO, GO TO SYNTAX PHASE JMP COMND YES, GO TO COMMAND PHASE LDA SYFLG LOAD SYNTAX SEGMENT FLAG SZA IS SEGMENT IN CORE? JSB BASC1 YES, BRANCH TO IT CCA SET SYNTAX SEGMENT FLAG STA SYFLG * LDB .1 LOAD JMP SGMNT SEGMENT #1 * BYE JSB EXEC TERMINATE BASIC DEF *+2 DEF .6 SKP * EXECUTION RETURNED HERE WHEN ERROR OCCURS * SET FOR PRINTING ERROR MESSAGE SPC 1 OUTER CCA SET L.U. NEGATIVE FOR FLAG STA LUOUT TO INDICATE ERROR MESSAGE JMP PLIST BRANCH TO LIST SEGMENT SPC 1 * EXECUTION RETURNED HERE AFTER PRINTING ERROR MESSAGE * SET FOR LOADING SYNTAX SEGMENT AGAIN SPC 1 ERRPT CLA CLEAR SYNTAX SEGMENT FLAG STA SYFLG STA PFLAG AND FILE FLAG INA SET FOR END STA REC# OF COMMAND FILE INPUT JMP PEXMK GO WAIT FOR INPUT * * GO TO SEG 6 TO INPUT COMMAND FILE * COMFL LDA .4 SET FOR STA PFLAG COMMAND FILE *******************************ADDED 790904**************************** CLB RESET INVOKE SC FILE # STB INNUM ************************************790904***************************** LDB .6 LOAD JMP SGMNT SEGMENT #6 FOR COMMAND FILE SKP * PROCESS SYSTEM COMMANDS SPC 1 * LOAD COMMAND SEGMENT SPC 1 * COMES HERE THROUGH SYNTAX SEGMENT (A) CONTAINS FIRST * CHARACTER OF COMMAND * COMND CLB CLEAR SYNTAX FLAG STB SYFLG LDB .5 LOAD SEG#5 FOR JMP SGMNT COMMANDS SPC 1 * PROCESS 'RUN' COMMAND SPC 1 RUN LDB .3 LOAD SEG#3 JMP SGMNT TO START EXECUTION SPC 1 SPC 1 * PROCESS 'SAVE' & 'LIST' COMMAND SPC 1 PLIST LDB .2 LOAD SEG#2 JMP SGMNT TO LIST PROGRAM SPC 1 * PROCESS 'LOAD' COMMAND SPC 1 LOADT LDA PFLAG IS INPUT CPA .1 FROM FILE? JMP LOADF YES! CPA .2 FROM 'CHAIN' JMP LOADF YES! CPA .5 RUN JMP LOADF YES! ************CHANGED FOR L 790604*********** LDA M2000 ISSUE ERROR FOR NO LU OR FILE NAME STA FERR JSB CKERR * LDA READR SET L.U. TO READER * STA LUINP * AND B77 ISOLATE L.U. # * IOR B700 MERGE IN FUNCTION CODE * STA LENTH SAVE IT * JSB EXEC CALL EXEC * DEF *+3 * DEF .3 TO SET EOT BIT * DEF LENTH * * MORTP LDA M80 * LDB .INBF * JSB REED GET RECORD FROM READER * CPA M1 END OF TAPE? * JMP RDYPT YES * SZA,RSS * JMP MORTP NULL RECORD * CCB SET PFLAG=-1 * STB PFLAG SET TAPE INPUT FLAG # 0 * JMP RPRCS GO PROCESS RECORD * *********790604******************************** LOADF JSB READF INPUT RECORD DEF *+6 DEF DCB,I DEF FERR DEF .INBF,I DEF .40 ***CHG FOR BUG 790928 MM*** DEF LENTH JSB CKERR FILE ERROR? LDA LENTH EOF? SZA,RSS ZERO LENGTH? JMP LOADF YES, GET ANOTHER SSA ENCOUNTERED? JMP LOAD1 YES, CLOSE RAL SET UP STA ICCNT CHAR COUNT FOR INPUT BUFFER JMP RPRCS NO, PROCESS RECORD * * LOAD1 LDA PFLAG 'CHAIN' CPA .2 STATEMENT? JMP RUN YES, RUN PROGRAM CPA .5 RUN ? JMP RUN YES! LDA REC# INPUT FROM COMMAND CPA .1 FILE? JMP RDYPT NO! JMP COMFL YES! * SKP *********************** *********************** * * * UTILITY SUBROUTINES * * * *********************** * * THE FOLLOWING SUBROUTINES ARE USED BY THE SEGMENTS OF THE * BASIC INTERPRETER AND THEREFORE ARE CORE RESIDENT. THEY * ARE DEFINED IN THE SEGMENTS AS BEING EXTERNAL. * * * * ******************** * * * CHECK FOR LETTER * * * ******************** LETCK NOP CHARACTER IN (A) LDB 0 ADB D133 ASCII 133B SSB,RSS OR GREATER? JMP LETCK,I YES, EXIT WITH CHARACTER IN (A) ADB .26 NO, ASCII 101B SSB,RSS OR GREATER? ISZ LETCK YES JMP LETCK,I NO ******************* * * * CHECK FOR DIGIT * * * ******************* DIGCK NOP CHARACTER IN (A) LDB 0 ADB D72 ASCII 72B SSB,RSS OR GREATER? JMP DIGCK,I YES, RETURN WITH CHARACTER ADB .10 NO, ASCII 60B SSB OR GREATER? JMP DIGCK,I NO ISZ DIGCK YES, SET 'SUCCESS' EXIT, LDA 1 LOAD DIGIT INTO (A), JMP DIGCK,I AND RETURN SKP ***************************** * * * ADD CHAR TO OUTPUT BUFFER * * * ***************************** OUTCR NOP CHARACTER IN (A) STA TEMP4 SAVE CHARACTER LDA .OTBF ADA .66 ***CHG FOR BUG 790928 MM*** CPA OTBFA TRUNCATE ANY CHARACTERS OVER 80 COLUMNS JMP OUTCR,I ISZ OCCNT COUNT CHARACTERS LDB OCCNT FIRST CHARACTER SLB OF BUFFER WORD? ISZ OTBFA YES, MOVE TO FRESH WORD LDA OTBFA,I LOAD BUFFER WORD SLB SAVE ALF,ALF OTHER AND M256 CHARACTER IOR TEMP4 ADD NEW CHARACTER SLB POSITION ALF,ALF WORD AND STA OTBFA,I STORE IT JMP OUTCR,I ****************************** * * * GET CHAR FROM INPUT BUFFER * * * ****************************** GETCR NOP ISZ ICCNT ANY CHARACTERS LEFT? RSS JMP GETCR,I NO, END-OF-FILE EXIT LDB INBFA LOAD BUFFER ADDRESS ISZ INBFA UPDATE FOR NEXT TIME CLE,ERB SET CHARACTER FLAG LDA 1,I LOAD CURRENT BUFFER WORD SEZ,RSS FIRST CHARACTER? ALF,ALF YES, POSITION IT AND B377 MASK EXTRANEOUS BITS***790817****** CPA BLANK BLANK? JMP GETCR+1 YES, FETCH NEXT CHARACTER ISZ GETCR UPDATE RETURN ADDRESS JMP GETCR,I AND EXIT *************************** * * * BACKSPACE OVER ONE CHAR * * * *************************** BCKSP NOP CCA BACKSPACE ADA ICCNT OVER STA ICCNT LAST CCA CHARACTER IN ADA INBFA INPUT STA INBFA BUFFER JMP BCKSP,I SKP ***************************** * * * INITIALIZE FOR NEW LINE * * * ***************************** * PRNIN NOP CCA INITIALIZE ADA .OTBF BUFFER STA OTBFA POINTER CLA INITIALIZE STA OCCNT CHARACTER COUNTER JMP PRNIN,I SPC 1 ************************* * * * OUTPUT COMPLETED LINE * * * ************************* OUTLN NOP LDA OCCNT OUTPUT LDB .OTBF A JSB WRITE LINE JSB PRNIN CLEAN UP OUTPUT BUFFER STA TYPE RESET PARTIAL LINE COUNTER JMP OUTLN,I * * ***************************** * * * CHECK FOR LINE OVERFLOW * * * ***************************** * * AT ENTRY, A = NUMBER OF CHARACTERS * TO BE OUTPUT, EXCLUSIVE * OF TRAILING BLANKS. * THIS ROUTINE CHECKS FOR LINES OVER 80 * CHARACTERS, AND OUTPUTS THEM BEFORE * FIGURING THE END OF FIELD FOR NUMERIC * FORMATTING. THE END OF FIELD COLUMN * NUMBER IS RETURNED IN TEM10. * OLNCK NOP STA BCKSP SAVE REQUEST LENGTH TEMPORARILY ADA OCCNT FIGURE LENGTH OF BUFFER ADA TYPE FIGURE COLUMN OF RESULT CMA,INA ADA .132 TOO MANY CHARS ?***CHG FOR BUG 790928 MM*** SSA JSB OUTLN YES, OUTPUT LINE FIRST LDA BCKSP RECOVER REQUEST LENGTH ADA OCCNT AND FIGURE ADA .3 THE END-OF-FIELD STA TEM10 COLUMN NUMBER JMP OLNCK,I SKP ******************************* * * * FIND OUT THE DEVICE TYPE * * * ******************************* * *THIS ROUTINE WAS CHANGED SO IT WILL NOW PASS BACK IN THE B REGISTER *THE INTERFACE TYPE FROM STATUS WORD 2. THIS IS TO ENABLE CHECKING *FOR HPIB DEVICES AND SETTING THE UE BIT IN THE CONTROL WORD TO ALLOW *THE USER TO TRAP I/O ERRORS. THIS ABILITY WAS ADDED TO THE L. * 800107 * * * ON INPUT (A) = LU NUMBER * ON EXIT (A) = DVR NUMBER * (B) = INTRF TYPE FOR L * FINDV NOP STA SLU SET UP STATUS EXEC CALL JSB EXEC TO FETCH EQUIP TYPE CODE DEF FIND1 AND SUBCHANNEL NUMBER DEF .13 DEF SLU DEF STAT1 DEF STAT2 *******************CHANGED 790829*********************************** * DEF SBCHN * * THE L DOES NOT SUPPORT SUBCHANNELS. THEREFORE, THIS PARAMETER * IS NOT NEEDED!!!!! * * *FIND1 LDA SBCHN FETCH SC AND * AND MSK0 REMOVE DOWN BIT * LDB 0 LEAVE IT IN (B) *************************CHANGED 800123******************************** FIND1 LDA STAT2 PICK UP INTERFACE TYPE ALF,ALF AND B77 STA B STUFF RESULT IN B LDA STAT1 FETCH EQUIP CODE ALF,ALF AND B77 ********************************800123************************************ JMP FINDV,I * .13 DEC 13 SLU NOP STAT1 NOP STAT2 NOP *SBCHN NOP *****REMOVED 790829****** * SKP ******************** * * * FIND A STATEMENT * * * ******************** * * UPON ENTRY (A) = SEQUENCE NUMBER TO BE FOUND. IF (A) * IS LARGER THAN ANY SEQUENCE NUMBER IN THE PROGRAM, EXIT * TO (P+1) WITH (B) POINTING TO LAST WORD+1 OF THE PROGRAM * IF (A) FALLS BETWEEN TWO SEQUENCE NUMBERS, EXIT TO (P+2) * WITH (B) POINTING TO THE STATEMENT WITH THE LARGER SEQUENCE * NUMBER. IF A STATEMENT IN THE PROGRAM HAS THE SEQUENCE * NUMBER THEN EXIT TO (P+3) WITH (B) POINTING TO THIS STATEMENT. * FNDPS NOP STA TEMP3 SAVE SEQUENCE NUMBER LDB PBUFF STARTING ADDRESS FNDP1 CPB PBPTR END OF PROGRAM? JMP FNDP4 YES, EXIT VIA (P+1) LDA TEMP3 SUBTRACT PROGRAM CMA,INA SEQUENCE NUMBER FROM ADA 1,I S-BUFFER SEQUENCE NUMBER SZA,RSS EQUAL? ISZ FNDPS YES, SET EXIT TO (P+3) SSA,RSS NO, P-SEQ NO > S-SEQ NO ? JMP FNDP3 YES, SET EXIT TO (P+2) LDA 1 POINT (A) TO INA PROGRAM ADDRESS INCREMENT ADB 0,I COMPUTE NEW ADDRESS JMP FNDP1 FNDP3 ISZ FNDPS FNDP4 STB TEMP3 SAVE STATEMENT ADDRESS JMP FNDPS,I ***************************** * * * MOVE WORDS TO HIGHER CORE * * * ***************************** MVTOH NOP LDB TEMP2 FETCH SOURCE ADDRESS MVTO1 CPB TEMP3 ALL RELOCATION DONE? JMP MVTOH,I YES, EXIT CCA BACK UP ADB 0 ADA TEMP4 SOURCE AND STA TEMP4 DESTINATION LDA 1,I MOVE STA TEMP4,I WORD JMP MVTO1 SKP *********************** * * * SEARCH SYMBOL TABLE * * * *********************** * * SSYMT IS CALLED WITH THE IDENTIFIER TO SEARCHED FOR IN * (A). IT RETURNS WITH THE ADDRESS OF THE MATCHING ENTRY * IN (B) OR (B)=-1 IF THERE IS NO MATCHING ENTRY. * * THE FOLLOWING RULES APPLY WHEN SEARCHING FOR ARRAYS: * * 1. TYPE 1 (ONE DIMENSION) SEARCH FOR CORRESPONDING * TYPE 1 OR TYPE 3 ARRAY. IF TYPE 3 IS FOUND CHANGE * THE ENTRY TO TYPE 1. * * 2. TYPE 2 (TWO DIMENSIONS) SEARCH FOR CORESPONDING * TYPES OR TYPE 3 ARRAY. IF TYPE 3 IS FOUND CHANGE * THE ENTRY TYPE TO TYPE 2. * * 3. TYPE 3 (UNDIMENSIONED) SEARCH FOR CORRESPONDING * TYPE 3 OR TYPE 1 OR TYPE 2 ARRAY. * SSYMT NOP STA STEMP STORE IDENTIFIER AND .15 ISOLATE IDENTIFIER TYPE ADA M4 SSA,INA JMP *+4 JUMP IF ARRAY TYPE LDA STEMP RESTORE A STA 1 STORE IN B JMP SYMT1+3 SSA SKIP IF UNDIMENSIONED JMP SYMT1 LDA STEMP RESTORE A AND MSK3 177771B SET TYPE TO 1 STA 1 INB SET TYPE IN B TO 2 JMP *+4 SYMT1 CCB SET DIMENSIONED FLAG IN B LDA .3 IOR STEMP SET TYPE TO UNDEFINED STA STEMP+1 STORE A STB STEMP+2 STORE B LDB SYMTF START OF SYMBOL TABLE JMP SYMT4 SYMT2 LDA 1,I PICK UP 1ST WORD OF ENTRY CPA STEMP COMPARE WITH IDENTIFIER JMP SSYMT,I MATCH ? RETURN CPA STEMP+1 COMPARE WITH DIFFERENT DIM. JMP SYMT3 CPA STEMP+2 COMPARE WITH DIFFERENT DIM. JMP SYMT3 LDA 1,I AND .15 ISOLATE ENTRY TYPE CPA .15 FUNCTION ? JMP *+5 YES ADA M4 SSA ARRAY ? INB YES INCREMENT POINTER INB INCREMENT POINTER ADB .2 ADD 2 TO POINTER SYMT4 CPB SYMTA SYMBOL TABLE EXHAUSTED? ? CCB,RSS YES JMP SYMT2 NO, CHECK NEXT ENTRY FOR MATCH LDA STEMP RETRIEVE SYMBOL JMP SSYMT,I RETURN WITH B NEGATIVE SYMT3 LDA STEMP RESTORE A ISZ STEMP+2 DIMENSIONED IDENTIFIER? RSS NO, SKIP STA 1,I YES CHANGE 1ST WORD OF ENTRY TO JMP SSYMT,I APPROPRIATE DIMENSION TYPE SKP ************************* * * * FORMATTER SUBROUTINES * * * ************************* * * THE FOLLOWING SUBROUTINES ARE USED BY THE SEGMENTS OF THE * BASIC INTERPRETER TO PERFORM I/O FORMATTING OPERATIONS. * IN GENERAL, THEY PROVIDE FOR ASCII-TO-BINARY AND BINARY- * TO-ASCII CONVERSIONS. * ******************** * * * PRINT A NUMBER * * * ******************** * * ENTER WITH A FLOATING PT NUMBER IN (A) AND (B). PRINT * THE NUMBER AND APPEND BLANKS TO REACH THE PRINT POSITION * SPECIFIED BY TEM10 ON RETURN FROM 'NUMOT'. * ENOUT NOP CCE ENABLE SIGN JSB NUMOT OUTPUT NUMBER ENOU0 LDB TEM10 FIELD ADB M132 ***CHG FOR BUG 790928 MM*** SSB,RSS OVERFLOW OF LINE WITH TRAILING BLNKS? JMP ENOUT,I LDB TEM10 FIELD CMB,INB ADB OCCNT SSB,RSS FULL? JMP ENOUT,I YES! LDA .32 NO, SO JSB OUTCR OUTPUT A BLANK JMP ENOU0 AND TRY AGAIN * MINFX DEC -0.099999959 MAXFX DEC -999999.5 NMBFA DEF *+1 NUMBF BSS 6 LDVSR DEF *+1 DEC 10000 DEC 1000 DEC 100 .10 DEC 10 SKP ************************ ** * *** OUTPUT A NUMBER * ** * ************************ * * ENTER WITH A FLOATING POINT NUMBER IN (A) AND (B) AND (E) = 1 * IF A SIGN IS WANTED. DETERMINE THE FORM OF THE NUMBER AND * SET TEM10 ACCORDINGLY. NON-INTEGERS ARE ROUNDED AFTER CONVERSION * TO DECIMAL. TRAILING ZEROS ARE SUPPRESSED ON NUMBERS WITHOUT * EXPONENTS. * NUMOT NOP STA NUMBF SAVE HIGH MANTISSA SEZ,RSS SIGN? JMP NUMO1 NO SSA,RSS YES, NEGATIVE NUMBER? JMP *+5 NO JSB ..FCM YES, NEGATE NUMBER STA NUMBF SAVE HIGH MANTISSA LDA .45 LOAD '-' RSS CLA LOAD '+' STA SIGN SAVE SIGN LDA NUMBF RETRIEVE HIGH MANTISSA NUMO1 STB NUMBF+1 SAVE LOW MANTISSA JSB IFIX INTEGER? JMP NUMO2 NO SOC YES, 16-BIT INTEGER? JMP NUMO2 NO * * ** OUTPUT AN INTEGER ** * * STB NUMBF SAVE INTEGER ADB M1000 LDA .3 SSB,RSS 3 DIGIT INTEGER? ADA .3 NO, ALL INTEGERS ARE 6 DIGITS OR LESS JSB OLNCK CHECK FOR LINE OVERFLOW LDA SIGN YES SZA SIGN? JSB OUTCR YES, OUTPUT IT LDA NUMBF NO JSB OUTIN OUTPUT THE INTEGER JMP NUMOT,I * * ** OUTPUT A FLOATING POINT NUMBER ** * * NUMO2 LDA M2 SET 'FIXED' STA FFLAG FLAG FALSE DLD NUMBF LOAD NUMBER FAD MAXFX IS NUMBER SSA,RSS < 999999.5 ? JMP NUMO3 NO DLD NUMBF YES, IS FAD MINFX NUMBER * LESS THAN SSA,RSS 0.09999995 ? ISZ FFLAG NO, SET 'FIXED' FLAG TRUE NUMO3 DLD NUMBF LOAD NUMBER STA MANT1 UNPACK JSB .FLUN STB MANT2 NUMBER STA EXPNT CLA INITIALIZE STA EXPON DECIMAL EXPONENT CPA EXPNT ZERO EXPONENT? JMP NUMO5 YES NUMO0 JSB MBY10 NO LDA EXPNT MULTIPLY CMA,SSA,INA,SZA NUMBER BY 10 JMP *+3 UNTIL IT IS ISZ EXPON GREATER JMP NUMO0 THAN 1 JSB DBY10 DIVIDE BY 10 LDA EXPON NUMO4 LDB EXPNT DIVIDE CMB,INB NUMBER SSB,RSS BY 10 JMP NUMO5 UNTIL STA EXPON IT IS JSB DBY10 LESS CCA THAN ADA EXPON 1 JMP NUMO4 NUMO5 CMA SET EXPONENT STA EXPON TO TRUE VALUE-1 LDB M6 SET DIGIT STB DIGCT COUNTER LDB NMBFA SET BUFFER STB NMPTR POINTER * * ** CONVERT MANTISSA TO ASCII ** * * NUMO6 JSB GETDG STORE A ADA .48 DECIMAL STA NMPTR,I DIGIT ISZ NMPTR ISZ DIGCT SIXTH DIGIT? JMP NUMO6 NO JSB GETDG YES, ADA M5 NEXT DIGIT SSA >= 5 ? JMP NUMO9+1 NO * * ** ROUND ASCII MANTISSA ** * * LDB NMPTR NUMO7 ADB M1 LOAD LAST LDA 1,I DIGIT INA INCREMENT IT CPA .58 WAS IT A 9 ? RSS YES JMP NUMO9 NO CPB NMBFA LEADING DIGIT? JMP NUMO8 YES LDA .48 NO, OVERLAY STA 1,I A 0 JMP NUMO7 NUMO8 ISZ EXPON BUMP DECIMAL NOP EXPONENT AND LDA .49 OVERLAY A 1 NUMO9 STA 1,I LDA EXPON IS NUMBER SSA,RSS LESS THAN 1 ? JMP NMO11 NO STA TEMP6 YES LDA .48 LDB NMPTR NMO10 ISZ TEMP6 COUNT ZEROS NOP PLUS 1 ADB M1 LAST CPA 1,I DIGIT 0? JMP NMO10 YES LDA TEMP6 NO, ALL SIGNIFICANCE SSA IN SIX DIGITS? JMP NMO11 NO CCA YES, SET STA FFLAG 'FIXED' FLAG TRUE NMO11 LDA .9 COMPUTE ISZ FFLAG FIELD ADA .3 WIDTH JSB OLNCK CHECK FOR LINE OVERFLOW LDA SIGN YES SZA SIGN? JSB OUTCR YES, OUTPUT IT LDB M7 SET OUTPUT STB DIGCT DIGIT COUNTER LDB NMPTR CCA FIXED CPA FFLAG FORMAT? JMP *+5 NO LDA EXPON YES, SET CMA INDICATOR TO STA TEMP6 DECIMAL POINT JMP NMO16 STA TEMP6 SET INDICATOR FOR DECIMAL POINT JMP NMO14 NO * * ** DELETE TRAILING ZEROS ** * * NMO12 LDA DIGCT AT RIGHT OF INA DECIMAL CPA TEMP6 POINT? JMP *+6 NO STA DIGCT YES, DELETE ZERO NMO16 ADB M1 LAST LDA 1,I DIGIT CPA .48 0? JMP NMO12 YES CCA NO, FIXED CPA FFLAG FORMAT? JMP NMO14 NO LDA EXPON YES, LEADING SSA,RSS DECIMAL POINT? JMP NMO14 NO STA TEMP6 YES, SET LEADING ZEROS COUNTER * * ** OUTPUT MANTISSA ** * * LDA .46 OUTPUT A RSS DECIMAL POINT NMO13 LDA .48 OUTPUT JSB OUTCR A ZERO ISZ TEMP6 MORE LEADING ZEROS? JMP NMO13 YES ISZ DIGCT NO, COUNT DECIMAL POINT NMO14 LDB NMBFA SET STB NMPTR DIGIT POINTER JMP *+5 NMO15 ISZ TEMP6 DECIMAL POINT NEXT? JMP *+3 NO LDA .46 YES, LOAD IT JMP *+3 LDA NMPTR,I LOAD NEXT ISZ NMPTR DIGIT JSB OUTCR OUTPUT CHARACTER ISZ DIGCT MORE DIGITS? JMP NMO15 YES ISZ FFLAG NO, EXPONENT? JMP NUMOT,I NO * * ** OUTPUT THE EXPONENT ** * * LDA E JSB OUTCR OUTPUT AN 'E' LDA .45 OUTPUT LDB EXPON SSB AN CMB,INB,RSS LDA .43 EXPONENT STB EXPON JSB OUTCR SIGN LDA EXPON CLB COMPUTE DIV .10 ADA .48 EXPONENT'S ADB .48 STB EXPON 10'S DIGIT JSB OUTCR OUTPUT IT LDA EXPON OUTPUT JSB OUTCR 1'S DIGIT JMP NUMOT,I SKP ********************* * * * OUTPUT AN INTEGER * * * ********************* OUTIN NOP INTEGER IN (A) LDB M4 SET DIGIT STB DIGCT COUNTER LDB LDVSR SET DIVISOR STB TEMP7 ADDRESS CLB SUPPRESS STB TEMP6 ZEROES OUTI1 DIV TEMP7,I DIVIDE INTEGER STB TEMP5 CURRENT DIVISOR CPA TEMP6 LEADING ZERO? JMP OUTI2 YES! ADA .48 NO, TURN OFF STA TEMP6 ZERO SUPPRESSION JSB OUTCR OUTPUT DIGIT OUTI2 CLB LDA TEMP5 RETRIEVE REMAINDER ISZ TEMP7 SET FOR NEXT DIVISOR ISZ DIGCT ALL DIVISOR USED? JMP OUTI1 NO! ADA .48 YES, OUTPUT JSB OUTCR LAST DIGIT JMP OUTIN,I * ****************************** * * * ASCII-TO-BINARY CONVERSION * * * ****************************** NUMCK NOP CHARACTER IN (A), SIGN SETE CLB STB EXPNT ZERO STB EXP STB MANT1 ALL STB MANT2 COMPONENTS STB EXPON OF NUMBER STB TEMP3 SET 'NUMBER' FLAG FALSE CCB SET 'DECIMAL POINT' STB DPFLG FLAG FALSE NUMC1 CPA .46 DECIMAL POINT? ISZ DPFLG YES, SET FLAG TRUE JMP NUMC2 NO CLA INITIALIZE POST-DECIMAL DIGIT STA EXPON DIGIT COUNTER TO ZERO JMP NUMC3+1 FETCH A CHARACTER NUMC2 JSB DIGCK DIGIT? JMP NUMC7 NO ISZ EXPON YES, COUNT DIGIT ALF,ALF LEFT-JUSTIFY ALF,RAR DIGIT AND STA TEMP4 SAVE IT JSB MBY10 MULTIPLY PREVIOUS NUMBER BY 10 LDB EXPNT SZB ZERO EXPONENT? JMP NUMC4 NO LDA .4 YES, SET STA EXPNT EXPONENT TO 4 LDA TEMP4 LOAD CLB NUMBER NUMC3 JSB NORML NORMALIZE THE NUMBER ISZ TEMP3 SET 'NUMBER OCCURRED' FLAG JSB GETCR ANOTHER CHARACTER? JMP NUM12 NO JMP NUMC1 YES NUMC4 ADB M4 COMPUTE CMB EXPONENT LDA TEMP4 BIAS AND STB TEMP4 SAVE IT CLB NUMC5 ISZ TEMP4 DIGIT POSITIONED? JMP NUMC6 NO CLE YES, ADD IN ADB MANT2 LOW PART CLO OF NUMBER SEZ OVERFLOW? INA YES, BUMP (A) ADA MANT1 ADD IN HIGH PART OF NUMBER SOS OVERFLOW? JMP NUMC3 NO CLE,ERA YES, ROTATE ERB DOWN AND ISZ EXPNT BUMP NOP EXPONENT JMP NUMC3 NUMC6 CLE,ERA SHIFT ERB DIGIT JMP NUMC5 RIGHT NUMC7 CLB DECIMAL POINT STB TEMP4 CPB TEMP3 OR DIGIT FOUND? JMP NUMCK,I NO, EXIT VIA (P+1) CPA E YES, 'E' ? RSS YES JMP NUM12 NO, NO EXPONENT PART JSB GETCR JMP NUMER CPA .43 '+' ? JMP NUMC8 YES CPA .45 NO, '-' ? CCA,RSS YES JMP NUMC9 NO STA TEMP4 NOTE MINUS SIGN NUMC8 JSB GETCR JMP NUMER NUMC9 JSB DIGCK DIGIT? JMP NUMER NO STA TEMP3 YES, SAVE IT JSB GETCR JMP NUM10 SECOND JSB DIGCK DIGIT? JMP NUM10 NO LDB TEMP3 YES BLS,BLS MULTIPLY ADB TEMP3 PRIOR DIGIT BLS BY 10 ADA 1 ADD NEW DIGIT STA TEMP3 SAVE EXPONENT JSB GETCR JMP NUM10 THIRD JSB DIGCK DIGIT? RSS NO JMP NUMER YES NUM10 LDA TEMP3 LOAD EXPONENT ISZ TEMP4 POSITIVE? CMA,INA YES, COMPLEMENT IT RSS NO NUM12 CLA CLEAR IF NO EXPONENT PART ISZ DPFLG DECIMAL POINT? ADA EXPON YES, CORRECT EXPONENT SZA,RSS ZERO EXPONENT? JMP NUM14 YES SKP SSA NO, NEGATIVE EXPONENT? JMP NUM13 NO CMA,INA YES, SET STA EXPON COUNTER JSB DBY10 DIVIDE NUMBER BY 10 ISZ EXPON DONE? JMP *-2 NO JMP NUM14 YES NUM13 STA EXPON SET COUNTER JSB MBY10 MULTIPLY BY 10 ISZ EXPON DONE? JMP *-2 NO NUM14 LDA EXPNT STA EXP LDA MANT1 YES, LOAD LDB MANT2 NUMBER ISZ SIGN POSITIVE? JMP NUM15 YES CMA NO, CMB,INB,SZB,RSS COMPLEMENT INA IT NUM15 JSB .PACK PACK NUMBER INTO (A) AND (B) EXP BSS 1 EXPONENT ISZ SBPTR STA SBPTR,I STORE ISZ SBPTR NUMBER IN STB SBPTR,I PROPER ISZ SBPTR LOCATION JSB BCKSP FETCH JSB GETCR FIRST LDA .10 UNUSED CHARACTER ISZ NUMCK NUMER ISZ NUMCK RETURN JMP NUMCK,I VIA (P+2) OR (P+3) SKP *************************************** * * * INTEGERIZE FLOATING POINT nUMBER * * * *************************************** * * ENTER WITH A F.P. NUMBER IN (A) AND (B). IF EXPONENT * EXCEEDS 23, NUMBER HAS INTEGER SIGNIFICANCE EXIT TO (P+1) * ALL OTHER CASES EXIT TO (P+2) WITH 32 BIT INTEGER RIGHT * JUSTIFIED IN (A) AND (B). ON EXIT (O) = 1 IF NUMBER IS EXACTLY * REPRESENTABLE AS 16 BIT INTEGER. IF EXPONENT IS NEGATIVE, TRUN- * CATE TO 0 OR -1 APPROPRIATELY AND LET (O) = 1. OTHERWISE RIGHT * JUSTIFY INTEGER AND EXIT WITH LAST BIT LOST IN (E). * IFIX NOP STO SET OVERFLOW FLAG STA MANT1 SAVE (A) CLA OCT 101050 LSR 8, GET EXPONENT ALF,ALF IN (A) AND BLF,BLF MANTISSA IN (B) SLA,RAR NEGATIVE EXPONENT? IOR SMASK YES, PROPAGATE SIGN SSA EXPONENT NON-NEGATIVE? JMP IFIX3 NO, RETURN 0 OR -1 ADA M16 SSA EXPONENT LESS THAN 16? CLO YES, CLEAR OVERFLOW ADA M8 SSA,RSS EXPONENT LESS THAN 24? JMP IFIX,I NO, ERROR EXIT, NO FRACTION * ADA M8 STA MANT2 SAVE SHIFT COUNT LDA MANT1 RETRIEVE HIGH MANTISSA JMP IFIX2 * IFIX1 CLE,SLA,ARS LONG RIGHT SHIFT CME SLB,ERB STO SET OVERFLOW IF 1 LOST IFIX2 ISZ MANT2 DONE? JMP IFIX1 NO, SHIFT SOME MORE ISZ IFIX DONE, SKIP (P+1) JMP IFIX,I RETURN (P+2) * IFIX3 LDA MANT1 NEGATIVE EXPONENT, RETRIEVE (A) CLE,SSA CCA,CCE TRUNCATE TO -1 OR 0 CLA,RSS CCB,RSS CLB JMP IFIX2+2 SKIP RETURN * SMASK OCT 77600 M16 DEC -16 SKP ********************************************* * * * SUBROUTINE TO COMPUTE THE ENTIER OF A&B * * * ********************************************* * * ENTER WITH NUMBER IN (A) AND (B). IF EXPONENT > 14 THEN * EXIT TO (P+1), ELSE EXIT TO (P+2) WITH THE ENTIER OF THE * ARGUMENT IN (A). * .IENT NOP JSB IFIX JMP .IENT,I OVERFLOW XOR 1 (A) SHOULD BE FULL OF SIGN BITS SSA (B) SHOULD HAVE A SIGN TOO JMP .IENT,I IT DOESNT, ERROR EXIT CPA 1 IF (A) WAS ZERO JMP *+3 ALL IS OK CMA IF (A) WAS -1 CPA 1 ISZ .IENT ALSO OK, SKIP RETURN JMP .IENT,I LEAVE WITH RESULT IN A AND B. SKP ********************* * * * FORMAT AN INTEGER * * * ********************* INTCK NOP CHARACTER IN (A) CLB STORE STB INTGR PARTIAL RESULT INTC1 JSB DIGCK DIGIT? JMP INTC2 NO CLO LDB INTGR MULTIPLY ADB 1 PARTIAL ADB 1 RESULT ADB INTGR BY ADB 1 10 ADB 0 ADD LATEST DIGIT SOC OVERFLOW? JMP INTC3 YES STB INTGR STORE PARTIAL RESULT JSB GETCR NO, FETCH LDA .10 NEXT CHARACTER JMP INTC1 INTC2 LDB INTGR ZERO SZB,RSS INTEGER? JMP INTC3 YES STB SBPTR,I NO, RECORD IT LDB INTCK,I INTEGER LDB 1,I TOO ADB INTGR LARGE? SSB,RSS JMP INTC3 YES LDB INTGR NO, ISZ SBPTR RETURN WITH ISZ INTCK INTEGER IN (B) INTC3 ISZ INTCK SET FOR 'FAIL' RETURN JMP INTCK,I SKP *********************** * * * GET DIGIT TO OUTPUT * * * *********************** GETDG NOP JSB MBY10 MULTIPLY BY 10 LDB EXPNT GET EXPONENT IN (B) CMB,INB AS NEGATIVE AND HIMSK KEEP 5 HIGH BITS OF (A) RAL NORMALIZE TO BIT 15 SSB,INB ROTATE INTEGER JMP *-2 INTO (A) AND MSK0 EXTRACT STA TEMP5 DIGIT LDB EXPNT ROTATE CMB,INB RAR BACK SSB,INB JMP *-2 XOR MANT1 REMOVE LDB MANT2 DIGIT JSB NORML NORMALIZE REMAINDER LDA TEMP5 LOAD (A) WITH DIGIT JMP GETDG,I *********************REMOVED 790817*********************** ************************************ * * * RETRIEVE CHAR FROM OUTPUT BUFFER * * * ************************************ *RETCR NOP * LDB OCCNT DECREMENT * ADB M1 CHARACTER * STB OCCNT COUNT * LDA OTBFA,I POSITION * SLB,RSS AND * ALF,ALF EXTRACT * AND MSK0 CHARACTER * SLB FIRST CHARACTER OF WORD? * JMP RETCR,I NO * LDB OTBFA YES, DECREMENT * ADB M1 BUFFER * STB OTBFA POINTER * JMP RETCR,I ******************************790817*************************** SKP ********************************** * * * MULTIPLY UNPACKED NUMBER BY 10 * * * ********************************** MBY10 NOP LDA MANT1 RETURN ON SZA,RSS ZERO JMP MBY10,I MANTISSA LDB EXPNT MULTIPLY ADB .3 BY STB EXPNT 8 LDB MANT2 LOAD MANTISSA CLE,ERA DIVIDE ERB BY CLE,ERA 4 ERB,CLE ADB MANT2 DOUBLE SEZ ADD TO INA PRODUCE ADA MANT1 1.25 * MANTISSA SSA,RSS CORRECT JMP *+5 CLE,ERA ON ERB ISZ EXPNT OVERFLOW NOP STA MANT1 STB MANT2 JMP MBY10,I ******************************** * * * DIVIDE UNPACKED NUMBER BY 10 * * * ******************************** DBY10 NOP MULTIPLY BY DOUBLE-LENGTH TENTH LDA MANT1 RETURN SZA,RSS ON ZERO JMP DBY10,I MANTISSA LDB M2 ADD EXPONENT OF ADB EXPNT 'TENTH' TO STB EXPNT MANTISSA EXPONENT LDA MANT2 JUSTIFY CLE,ERA LOWER MANTISSA MPY TENTH MULITPLY BY ONE-TENTH(63146) CLE,ELA SHIFT ELB,CLE BACK ADA 1 ADD IN LOWER MANTISSA* SEZ TENTH*(2)-16 INB AND ROUND STB MANT2 TO 16 BITS LDA MANT1 DO MPY TENTH SAME FOR CLE HIGH ADA 1 MANTISSA ADA MANT2 (EFFECTIVELY) SUM SEZ DOUBLE-LENGTH INB PRODUCTS STB MANT1 EXCHANGE STA 1 (A) AND (B) LDA MANT1 REGISTERS JSB NORML NORMALIZE RESULT JMP DBY10,I ******************************* * * * NORMALIZE (A), (B) AND EXPNT* * * ******************************* NORML NOP STA TEMP3 SET LEFT-SHIFT CLA COUNTER STA FERR TO ZERO LDA TEMP3 SZA,RSS ON SZB ZERO JMP NORM3 CLEAR STA EXPNT EVERYTHING STA MANT1 STORE NORM1 STB MANT2 MANTISSA JMP NORML,I AND RETURN NORM2 ISZ FERR COUNT LEFT SHIFTS NORM3 CLE,ELB ROTATE (A) AND ELA (B) LEFT INTO (E) SEZ,SSA,RSS TWO HIGHEST BITS 0? JMP NORM2 YES, + UNNORMALIZED SEZ,SSA NO, TWO HIGHEST BITS 1? JMP NORM2 YES, - UNNORMALIZED ERA SHIFT TO ERB,CLE NORMALIZE MANTISSA STA MANT1 NO, LDA FERR COMPUTE CMA,INA CORRECTED ADA EXPNT EXPONENT STA EXPNT VALUE LDA MANT1 JMP NORM1 SKP SPC 3 TEMP1 EQU TEMPS+2 TEMP2 EQU TEMPS+3 TEMP3 EQU TEMPS+4 STEMP EQU TEMPS+4 TEMP4 EQU TEMPS+5 TEMP5 EQU TEMPS+6 TEMP6 EQU TEMPS+7 TEMP7 EQU TEMPS+8 TEMP8 EQU TEMPS+9 TEMP9 EQU TEMPS+10 TEM10 EQU TEMPS+11 FFLAG EQU TEMPT+1 DPFLG EQU TEMPT+2 NMPTR EQU TEMPT+3 DIGCT EQU TEMPT+4 FERR EQU TEMPT+5 FILE ERROR FLAG LENTH EQU TEMPT+8 EXPON EQU TEMPT+9 INTGR EQU TEMPT+1 SKP ******************* * * * I/O SUBROUTINES * * * ******************* * * THE FOLLOWING SUBROUTINES ARE PRIMARILY USED BY THE BASIC * MAIN CONTROL FOR DOING I/O. THE INDIVIDUAL SEGMENTS MAY * ALSO CONTAIN SOME SPECIALIZED I/O ROUTINES. * *********************** * * * PRINT A LINE * * * *********************** WRITE NOP ENTRY SSA,RSS IF LENGTH > 0, MAKE CMA,INA NEGATIVE FOR CHARS STA LENTH SAVE IT STB WBUF1 SAVE BUFFER ADDRESS STB WBUF2 LDB FLTYP TYPE 0 SZB,RSS OUTPUT? JMP WRIT1 YES! JSB REIO RE-ENTRANT I/O DEF *+5 DEF WCODE TO PRINT DEF LUOUT WBUF1 BSS 1 LINE ON DEF LENTH JMP RWERR ERROR CODE IF THIS IS EXECUTED JMP WRITE,I TTY * WRIT1 JSB WRITF WRITE DEF *+5 DEF DCB,I TO DEF FERR WBUF2 DEF 0 TYPE 0 FILE DEF LENTH JSB CKERR ERROR? CCB SET FOR STB FLTYP NON-TYPE 0 OUTPUT JMP WRITE,I * ************************ * * * READ A LINE * * * ************************ REED NOP ENTRY STA LENTH SAVE BUFFER LENGTH STB KBUF1 AND ADDRESS STB KBUF2 LDB FLTYP TYPE 0 SZB,RSS FILE? JMP REED1 YES! ***************ADD FOR BUG 790928 MM*************** ADA M1 CHANGE LENTH TO READ IN 81 STA LENTH CHARS INSTEAD OF 80 *************************************************** JSB REIO CALL REIO DEF *+5 DEF RCODE TO READ A DEF LUINP KBUF1 BSS 1 LINE OF ASCII DEF LENTH JMP RWERR ILLEGAL READ(PROBABLY ILLEGAL LU) ******************CHANGED 800124************************************* STA MANT1 LDA LUINP CHECK FOR UE BIT SET AND BIT13 SZA,RSS JMP CONT NOT SET GO NORMAL LDA MANT1 CHECK FOR DOWN STATUS (BIT0=1) SLA JMP REED4 YES, ERROR OCCURRED ON READ CONT CPB .81 IF WE DID READ IN 81 CHARS RSS THEN WE HAVE AN ERROR JMP CONT1 ELSE WE DON'T HAVE AN ERROR **************CHANGED 800318******************************** CLA STA .LNUM LDA M2001 FORCE IN ERROR STA TEMP3 JMP OUTER ************************800318****************************** CONT1 LDA MANT1 STB LENTH AND .32 END OF SZA PAPER TAPE? JMP REED2 YES LDA MANT1 AND B200 EOF ON SZA CARTRIDGE TAPE? REED2 CCB YES! REED3 LDA 1 NO, RETURN WITH JMP REED,I LENGTH IN (A) * REED4 CLB ZERO LENGTH STB LENTH DUE TO ERROR IN READ JMP REED3 * ************************800124*************************************** REED1 LDA LENTH CMA,INA ARS STA LENTH JSB READF READ DEF *+6 DEF DCB,I A DEF FERR KBUF2 DEF 0 LINE DEF LENTH DEF LENTH FROM TYPE 0 FILE JSB CKERR ERROR? CCB SET FOR STB FLTYP NON-TYPE 0 INPUT LDA LENTH ALS SET FOR CHARACTER COUNT JMP REED,I * BIT13 OCT 20000 * * ************************** * * * CHECK FOR FILE ERROR * * * ************************** * CKERR NOP LDA FERR FILE SSA,RSS ERROR? JMP CKERR,I NO STA TEMP3 JMP OUTER YES, PRINT MESSAGE * RWERR LDA M4 ILLEGAL READ/WRITE STA FERR JSB CKERR * END BASIC