seppdroid/Digital-Research-Source-Code
1
0
Fork 0
mirror of https://github.com/SEPPDROID/Digital-Research-Source-Code.git synced 2025-10-23 00:14:25 +00:00
Code Issues Actions Packages Projects Releases Wiki Activity

Upload

Browse Source 
Digital Research
This commit is contained in:
Sepp J Morris
2020-11-06 18:50:37 +01:00
parent 621ed8ccaf
commit 31738079c4
8481 changed files with 1888323 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

30
ASSEMBLY & COMPILE TOOLS/Basic-E/source/BASCOM.LIT Normal file
View File

@@ -0,0 +1,30 @@
DECLARE
LIT LITERALLY 'LITERALLY',
TRUE LIT '1',
FALSE LIT '0',
FOREVER LIT 'WHILE TRUE',
INDEXSIZE LIT 'ADDRESS',
STATESIZE LIT 'ADDRESS',
LF LIT '0AH',
QUESTIONMARK LIT '3FH',
POUNDSIGN LIT '23H',
UPARROW LIT '5EH',
TAB LIT '09H',
COLIN LIT '3AH',
ASTRICK LIT '2AH',
PERCENT LIT '25H',
IDENTSIZE LIT '32', /* MAX IDENTIFIER SIZE + 1 */
VARCSIZE LIT '100', /* SIZE OF VARC STACK */
PSTACKSIZE LIT '32', /* SIZE OF PARSE STACKS */
EOLCHAR LIT '0DH', /* END OF SOURCE LINE INDICATOR */
EOFFILLER LIT '1AH', /* PAD CHAR FOR LAST REC ON FILE */
SOURCERECSIZE LIT '128', /* SIZE OF SOURCE FILE REC */
/* NOTE: THIS IS MAX SIZE OF SOURCE FILE RECORDS
IF SOURCE FILE CONSISTS OF VAR LNG REC */
INTRECSIZE LIT '128', /* INTERMEDIATE FILE REC SIZE */
CONBUFFSIZE LIT '82', /* SIZE OF CONSOLE BUFFER */
HASHTBLSIZE LIT '64', /* SIZE OF HASHTABLE */
HASHMASK LIT '63', /* HASHTBLSIZE - 1 */
STRINGDELIM LIT '22H', /* CHAR USED TO DELIM STRINGS */
CONTCHAR LIT '5CH', /* CONTINUATION CHARACTER */
MAXONCOUNT LIT '15'; /* MAX NUMBER ON STATEMENTS */

BIN
ASSEMBLY & COMPILE TOOLS/Basic-E/source/BASIC.COM Normal file
View File

Binary file not shown.

996
ASSEMBLY & COMPILE TOOLS/Basic-E/source/BASIC.PLM Normal file
View File

@@ -0,0 +1,996 @@
BASCOM:
DO;
/* BASIC - E COMPILER MODIFIED FOR RESIDENT OPERATION
BY GARY A. KILDALL, DIGITAL RESEARCH, PACIFIC GROVE, CA.
VERSION 1.4 - ORIGINAL DISTRIBUTION BY EUBANKS, NPS,
VERSION 1.5 - FIXES UNINITIALIZED STORAGE PROBLEMS
WFCB(32) = 0, RFCB(12) = 0, CONT = 0
HASHTABLE = 0...0
ALLOWS $ PARAMETERS IN CALL, RATHER THAN PROGRAM
*/
DECLARE JMPTOMAIN (3) BYTE DATA(0C3H,0,0); /* FILLED WITH DDT */
/*
*********************************************************
* *
* BASIC-E COMPILER *
* *
* U. S. NAVY POSTGRADUATE SCHOOL *
* MONTEREY, CALIFORNIA *
* *
* WRITTEN BY GORDON EUBANKS, JR. *
* *
* CPM VERSION 1.4 *
* *
* DECEMBER 1976 *
* *
*********************************************************
*/
/*
*********************************************************
* *
* THE BASIC-E COMPILER IS DIVIDED INTO THE FOLLOW- *
* ING MAJOR SECTIONS: *
* (1) GLOBAL DECLERATIONS AND LITERAL *
* DEFINITIONS *
* (2) SYSTEM INPUT OUTPUT ROUTINES AND *
* ASSOCIATED VARIABLE DECLERATIONS *
* (3) SCANNER *
* (4) SYMBOL TABLE ROUTINES *
* (5) PARSER AND CODE GENERATION *
* *
* BASIC-E REQUIRES A SOURCE PROGRAM AVAILABLE ON *
* AN INPUT DEVICE AND WILL WRITE A BINARY OUTPUT *
* FILE WHICH MAY BE EXECUTED BY THE RUN TIME *
* MONITOR. THE SOURCE MUST BE READ TWICE. *
* THE NORMAL OUTPUT DEVICE IS THE CONSOLE. *
* *
* MODIFICATION OF THE COMPILER FOR OTHER OPERATING *
* SYSTEMS WILL REQUIRE MODIFICATIONS TO SECTION *
* (2) AND IN SECTION 1 REDEFINITION OF LITERALS IN *
* SECTIONS "SYSTEM PARAMETERS WHICH MAY REQUIRE *
* MODIFICATION BY USERS" AND "EXTERNAL ENTRY *
* POINTS". OTHER CHANGES SHOULD NOT BE REQUIRED *
* *
*********************************************************
*/
/*
**********************************************************
* *
* **** SECTION 1 **** *
* *
**********************************************************
*/
/*
*********************************************************
* *
* GLOBAL LITERALS *
* *
*********************************************************
*/
$INCLUDE(:F1:BASCOM.LIT)
/*
*********************************************************
* *
* EXTERNAL ENTRY POINTS *
* THESE ENTRY POINTS ALLOW INTERFACING WITH CP/M *
* *
*********************************************************
*/
DECLARE
BDOS LIT '05H', /* ENTRY POINT TO CP/M */
PARMS LIT '6DH', /* $ PARAMETERS */
BOOT LIT '0H'; /* RETURN TO SYSTEM */
MON1: PROCEDURE(F,A);
DECLARE F BYTE, A ADDRESS;
/* PATCHED WITH JMP 0005 */
L: GO TO L;
END MON1;
MON2: PROCEDURE(F,A) BYTE;
DECLARE F BYTE, A ADDRESS;
/* PATCHED WITH JMP 0005 */
L: GO TO L;
RETURN 0;
END MON2;
MON3: PROCEDURE PUBLIC;
/* USED TO RETURN TO CP/M */
DECLARE A ADDRESS; A = BOOT;
CALL A;
END MON3;
/*
*********************************************************
* *
* GLOBAL VARIABLES *
* *
*********************************************************
*/
DECLARE
PASS1 BYTE PUBLIC INITIAL(TRUE), /* PASS1 FLAG */
PASS2 BYTE PUBLIC INITIAL(FALSE), /* PASS2 FLAG */
/*
COMPILER TOGGLES
*/
LISTPROD BYTE PUBLIC INITIAL(FALSE),
LISTSOURCE BYTE PUBLIC INITIAL(FALSE),
DEBUGLN BYTE PUBLIC INITIAL(FALSE),
LOWERTOUPPER BYTE INITIAL(TRUE),
NOINTFILE BYTE INITIAL(FALSE),
LSTFLAG BYTE INITIAL(FALSE), /* LST DEVICE IF 'F' */
ERRSET BYTE INITIAL(FALSE),
ERRORCOUNT ADDRESS PUBLIC INITIAL(0),
COMPILING BYTE PUBLIC,
DATACT ADDRESS PUBLIC, /* COUNTS SIZE OF DATA AREA */
/* FLAGS USED DURING CODE GENERATION */
FORSTMT BYTE PUBLIC,
RANDOMFILE BYTE PUBLIC,
FILEIO BYTE PUBLIC,
INPUTSTMT BYTE PUBLIC,
GOSUBSTMT BYTE PUBLIC,
/* THE FOLLOWING GLOBAL VARIABLES ARE USED BY THE SCANNER */
TOKEN BYTE PUBLIC, /* TYPE OF TOKEN JUST SCANNED */
SUBTYPE BYTE PUBLIC, /* SUBTYPE OF CURRENT TOKEN */
FUNCOP BYTE PUBLIC, /* IF TOKEN FUNC THEN THIS IS FUNC NUMBER */
HASHCODE BYTE PUBLIC, /* HASH VALUE OF CURRENT TOKEN */
NEXTCHAR BYTE PUBLIC, /* CURRENT CHARACTER FROM GETCHAR */
ACCUM(IDENTSIZE) BYTE PUBLIC, /* HOLDS CURRENT TOKEN */
ACCLEN BYTE PUBLIC AT(.ACCUM(0)), /* ACCUM 0 IS LENGTH */
CONT BYTE PUBLIC, /* INDICATES ACCUM WAS FULL, STILL MORE */
COLUMN BYTE INITIAL(0), /* CURRENT COLUMN */
/*
**************************************************
* *
* THE FOLLOWING LITERAL DEFINITIONS ESTABLISH *
* MNEMONIC NAMES FOR THE TOKENS WHICH ARE THE *
* OUTPUT OF THE LALR PARSER PROGRAM. *
* *
**************************************************
*/
POUND LIT '12', LPARN LIT '02', RPARN LIT '05',
ASTRK LIT '04', TPLUS LIT '03', TMINUS LIT '07',
LESST LIT '01', TCOLIN LIT '11', SCOLN LIT '06',
EXPON LIT '14', EQUAL LIT '13', GTRT LIT '10',
TDATA LIT '99', TAND LIT '24', TCR LIT '23',
TELSE LIT '34', TDEF LIT '25', TDIM LIT '26',
TFOR LIT '28', TEND LIT '27', TFILE LIT '35',
TIF LIT '17', TGOSB LIT '43', TGOTO LIT '36',
TNEXT LIT '37', TINPT LIT '44', TLET LIT '29',
SLASH LIT '08', TNOT LIT '30', TON LIT '20',
TOR LIT '21', TPRNT LIT '45', TREAD LIT '38',
TREST LIT '48', TRETN LIT '46', TSTEP LIT '39',
TSTOP LIT '40', TTHEN LIT '41', TTO LIT '22',
FUNCT LIT '53', TGEQ LIT '15', TSUB LIT '32',
TLEQ LIT '18', COMMA LIT '09', TGO LIT '16',
TNE LIT '19', TCLOS LIT '42', TXOR LIT '33',
TOUT LIT '31', TIRN LIT '51', STRING LIT '50',
IDENTIFIER LIT '52', FLOATPT LIT '49',
UDFUNCT LIT '54', TREM LIT '0';
/*
*********************************************************
* *
* **** SECTION 2 **** *
* *
* SYSTEM DEPENDENT ROUTINES AND VARIABLES *
* *
* THE FOLLOWING ROUTINES ARE USED *
* BY THE COMPILER TO ACCESS DISK *
* FILES AND THE CONSOLE. THESE *
* ROUTINES ASSUME THE USE OF THE *
* CP/M DISK OPERATING SYSTEM. *
* *
* THE FCB'S ARE USED BY THE SYSTEM TO MAINTAIN *
* INFORMATION ON OPEN FILES. THEY ARE ONLY USED *
* BY PROCEDURES IN THIS SECTION. THE BUFFERS *
* AND POINTERS TO THE BUFFERS ARE USED BY THE *
* REMAINDER OF THE PROGRAM BUT THEIR SIZE MAY *
* BE VARIED TO SUIT THE DISK SYSTEM BEING USED *
* *
*********************************************************
*/
DECLARE
PARMLIST(9) BYTE INITIAL(' '), /* $ PARAMS SAVED HERE */
RFCBADDR ADDRESS INITIAL(5CH),
/* NOTE: CP/M PROVIES 5CH AS FCB AREA AND 80H AS A
BUFFER FOR PROGRAM USE */
RFCB BASED RFCBADDR(33) BYTE, /* SOURCE FCB */
WFCB(33) BYTE /* INTERMEDIATE FILE FCB */
INITIAL(0,' ','INT',0,0,0,0),
SBLOC ADDRESS INITIAL(80H),
SOURCEBUFF BASED SBLOC(SOURCERECSIZE)BYTE, /* SOURCE BUFFER */
SOURCEPTR BYTE INITIAL(SOURCERECSIZE), /* BUFFER INDEX */
CURSOURCERECSIZE BYTE INITIAL(SOURCERECSIZE),
DISKOUTBUFF(INTRECSIZE) BYTE,
BUFFPTR BYTE INITIAL(255), /* BUFFER INDEX */
LINEBUFF(CONBUFFSIZE) BYTE, /* CONSOLE OUT BUFFER */
LINEPTR BYTE INITIAL(0), /* BUFFER INDEX */
LINENO ADDRESS PUBLIC, /* CURRENT LINE NUMBER */
SEPARATOR BYTE PUBLIC INITIAL(COLIN);
DECLARE
PCHAR LIT '2', /* CHAR TO CONSOLE */
PBUFF LIT '9', /* BUFFER TO CONSOLE */
RCHAR LIT '1', /* CHAR FROM CONSOLE */
RBUFF LIT '10', /* BUFFER FROM CONSOLE */
OFILE LIT '15', /* OPEN FILE */
CFILE LIT '16', /* CLOSE FILE */
DFILE LIT '19', /* DELETE FILE */
RFILE LIT '20', /* READ FILE */
WFILE LIT '21', /* WRITE FILE */
MFILE LIT '22', /* MAKE FILE */
SDMA LIT '26', /* SET DMA */
FILEERR LIT '255', /* ERROR RTN CODE */
FILEEOF LIT '1'; /* EOF RTN CODE */
MOVE: PROCEDURE (SOURCE,DEST,COUNT) PUBLIC;
DECLARE
SOURCE ADDRESS,
DEST ADDRESS,
COUNT BYTE,
SCHAR BASED SOURCE BYTE,
DCHAR BASED DEST BYTE;
DO WHILE(COUNT := COUNT -1) <> 255;
DCHAR = SCHAR;
SOURCE = SOURCE + 1;
DEST = DEST + 1;
END;
RETURN;
END MOVE;
FILL: PROCEDURE (DEST,CHAR,COUNT) PUBLIC;
/* MOVE CHAR TO A N TIMES */
DECLARE
DEST ADDRESS,
CHAR BYTE,
COUNT BYTE,
DCHAR BASED DEST BYTE;
DO WHILE (COUNT := COUNT -1) <> 255;
DCHAR = CHAR;
DEST = DEST + 1;
END;
RETURN;
END FILL;
CHAROUT: PROCEDURE(CHAR);
DECLARE CHAR BYTE;
IF LSTFLAG THEN /* GO TO THE LIST DEVICE */
CALL MON1(5,CHAR); ELSE CALL MON1(2,CHAR);
END CHAROUT;
PRINTCHAR: PROCEDURE(CHAR);
DECLARE CHAR BYTE;
/* CHECK FOR TABS AND END OF LINE */
IF CHAR = TAB THEN /* EXPAND TO NEXT COLUMN */
DO WHILE ((COLUMN := COLUMN + 1) AND 7) <> 0;
CALL CHAROUT(' ');
END; ELSE
DO; COLUMN = COLUMN + 1; CALL CHAROUT(CHAR);
IF CHAR = LF THEN COLUMN = 0;
END;
END PRINTCHAR;
PRINT: PROCEDURE(A) PUBLIC;
DECLARE A ADDRESS;
DECLARE MSG BASED A BYTE;
DO WHILE MSG <> '$';
CALL PRINTCHAR(MSG);
A = A + 1;
END;
END PRINT;
DISKERR: PROCEDURE;
CALL PRINT(.('DE $'));
CALL MON3; /* RETURN TO SYSTEM */
RETURN;
END DISKERR;
OPEN$SOURCEFILE: PROCEDURE;
/* SETS UP THE FCB FOR THE SOURCE PROGRAM
WHICH MUST BE OF TYPE 'BAS' AND THEN OPENS
THE FILE. CP/M PUTS THE NAME USED AS A
PARAMETER WHEN THE COMPILER IS EXECUTED, AT
5CH.
*/
CALL MOVE(.('BAS'),RFCBADDR+9,3);
RFCB(32),RFCB(12) = 0;
IF MON2(OFILE,RFCBADDR) = FILEERR THEN
DO;
CALL PRINT(.('NS $'));
CALL MON3; /* RETURN TO SYSTEM */
END;
END OPEN$SOURCEFILE;
REWIND$SOURCE$FILE: PROCEDURE PUBLIC;
/* CP/M DOES NOT REQUIRE ANY ACTION PRIOR TO REOPENING */
RETURN;
END REWIND$SOURCE$FILE;
CLOSE$INT$FILE: PROCEDURE PUBLIC;
IF MON2(CFILE,.WFCB) = FILEERR THEN
CALL DISKERR;
END CLOSE$INT$FILE;
SETUP$INT$FILE: PROCEDURE PUBLIC;
/* MAKES A NEW FILE */
IF NOINTFILE THEN /* ONLY MAKE FILE IF THIS TOGGLE IS OFF */
RETURN;
CALL MOVE(.RFCB,.WFCB,9);
CALL MON1(DFILE,.WFCB);
IF MON2(MFILE,.WFCB) = FILEERR THEN
CALL DISKERR;
WFCB(32) = 0; /* ZERO NEXT RECORD */
END SETUP$INT$FILE;
READ$SOURCE$FILE: PROCEDURE BYTE;
DECLARE DCNT BYTE;
IF(DCNT := MON2(RFILE,RFCBADDR)) > FILEEOF THEN
CALL DISKERR;
RETURN DCNT; /* ZERO IF READ ELSE 1 IF EOF - ERRORS > 1 */
END READ$SOURCE$FILE;
WRITE$INT$FILE: PROCEDURE PUBLIC;
IF NOINTFILE THEN
RETURN;
CALL MON1(SDMA,.DISKOUTBUFF);
IF MON2(WFILE,.WFCB) <> 0 THEN
CALL DISKERR;
CALL MON1(SDMA,80H); /* RESET DMA ADDRESS */
END WRITE$INT$FILE;
CRLF: PROCEDURE PUBLIC;
CALL PRINTCHAR(EOLCHAR);
CALL PRINTCHAR(LF);
RETURN;
END CRLF;
PRINT$DEC: PROCEDURE(VALUE) PUBLIC;
/*
CONVERTS VALUE TO A DECIMAL NUMBER WHICH IS PRINTED
ON THE CONSOLE. USED FOR LINENUMBERING STATEMENTS
AND TO PRINT PRODUCTIONS.
*/
DECLARE
VALUE ADDRESS,
I BYTE,
FLAG BYTE,
COUNT BYTE;
DECLARE DECIMAL(4) ADDRESS DATA(1000,100,10,1);
FLAG = FALSE;
DO I = 0 TO 3;
COUNT = 30H;
DO WHILE VALUE >= DECIMAL(I);
VALUE = VALUE - DECIMAL(I);
FLAG = TRUE;
COUNT = COUNT + 1;
END;
IF FLAG OR (I >= 3) THEN
CALL PRINTCHAR(COUNT);
ELSE
CALL PRINTCHAR(' ');
END;
RETURN;
END PRINTDEC;
SETFLAGS: PROCEDURE PUBLIC;
/*
RESET COMPILER FLAGS USED DURING PARSING
*/
RANDOMFILE,FILEIO,
INPUTSTMT, FORSTMT, GOSUBSTMT = FALSE;
END SETFLAGS;
/*
*********************************************************
* *
* THE FOLLOWING ROUTINE GENERATES THE INTERMEDIATE *
* LANGUAGE FILE. EMIT IS THE ONLY ROUTINE TO *
* ACTUALLY WRITE TO THE DISK. GENERATE, EMITDAT, *
* AND EMITCON CALL EMIT. *
* *
*********************************************************
*/
EMIT: PROCEDURE(OBJCODE) PUBLIC;
DECLARE OBJCODE BYTE;
IF (BUFFPTR:=BUFFPTR + 1) >= INTRECSIZE THEN /* WRITE TO DISK */
DO;
CALL WRITE$INT$FILE;
BUFFPTR = 0;
END;
DISKOUTBUFF(BUFFPTR) = OBJCODE;
RETURN;
END EMIT;
/*
*********************************************************
* *
* *** SCANNER SECTION *** *
* *
*********************************************************
*/
CLEAR$LINE$BUFF: PROCEDURE;
CALL FILL(.LINEBUFF,' ',CONBUFFSIZE);
END CLEAR$LINE$BUFF;
LIST$LINE: PROCEDURE(LENGTH);
DECLARE
LENGTH BYTE,
I BYTE;
CALL PRINT$DEC(LINENO);
CALL PRINT$CHAR(SEPARATOR);
CALL PRINT$CHAR(' ');
DO I = 0 TO LENGTH;
CALL PRINT$CHAR(LINEBUFF(I));
END;
CALL CRLF;
CALL CLEAR$LINE$BUFF;
SEPARATOR = COLIN;
END LIST$LINE;
/*
**********************************************************
* *
* GETCHAR SETS THE GLOBAL VARIABLE NEXTCHAR TO THE *
* NEXT SOURCEFILE CHARACTER AND RETURNS NEXTCHAR TO *
* THE CALLING ROUTINE. *
* *
* TABS ARE REPLACED WITH A BLANK AND IF EITHER *
* LISTSOURCE IS TRUE OR AN ERROR HAS OCCURED LINES *
* ARE OUTPUT TO THE CONSOLE. *
* *
**********************************************************
*/
GETCHAR: PROCEDURE BYTE PUBLIC;
DECLARE ADDEND(*) BYTE
DATA ('END',EOLCHAR,LF); /*TO ADD END IF LEFT OFF */
NEXT$SOURCE$CHAR: PROCEDURE BYTE;
RETURN SOURCEBUFF(SOURCEPTR);
END NEXT$SOURCE$CHAR;
CHECKFILE: PROCEDURE BYTE;
/*
CHECKFILE MAINTAINS THE SOURCE BUFFER FULL AND
CHECKS FOR END OF FILE ON THE SOURCE FILE.
IF A LINE FEED IS FOUND IT IS SKIPPED.
IF END OF FILE IS DETECTED THEN TRUE IS RETURNED
ELSE FALSE IS RETURNED.
*/
DO FOREVER; /* ALLOW US TO SKIP LINE FEEDS */
IF (SOURCEPTR := SOURCEPTR + 1) >= CURSOURCERECSIZE THEN
DO;
SOURCEPTR = 0;
IF READ$SOURCE$FILE = FILEEOF THEN
RETURN TRUE;
END;
IF (NEXTCHAR := NEXT$SOURCE$CHAR) <> LF THEN
RETURN FALSE;
END; /* OF DO FOREVER */
END CHECKFILE;
IF CHECKFILE OR (NEXTCHAR = EOFFILLER) THEN
DO; /* EOF REACHED */
CALL MOVE(.ADDEND,SBLOC,5);
SOURCEPTR = 0;
NEXTCHAR = NEXT$SOURCE$CHAR;
END;
IF LINEPTR < CONBUFFSIZE THEN
LINEBUFF(LINEPTR := LINEPTR + 1) = NEXTCHAR; /* OUTPUT LINE */
IF NEXTCHAR = EOLCHAR THEN
DO;
LINENO = LINENO + 1;
IF LISTSOURCE OR ERRSET THEN
CALL LISTLINE(LINEPTR - 1); /* NOT EOLCHAR */
LINEPTR = 0;
END;
IF NEXTCHAR = TAB THEN
NEXTCHAR = ' '; /* ONLY NEED REPLACE WITH 1 BLANK */
RETURN NEXTCHAR;
END GETCHAR;
GETNOBLANK: PROCEDURE;
DO WHILE((GETCHAR = ' ') OR (NEXTCHAR = EOFFILLER));
END;
RETURN;
END GETNOBLANK;
CHECK$CONTINUATION: PROCEDURE;
/*
CHECK FOR CONTINUATION CHAR. IF FOUND SET NEXTCHAR
TO FIRST CHARACTER ON NEXT LINE. IT THEN LOOKS TO
THE PARSER AS IF IT WAS ALL ONE LINE.
*/
IF NEXTCHAR = CONTCHAR THEN
DO;
DO WHILE GETCHAR <> EOLCHAR;
END;
CALL GETNOBLANK;
END;
RETURN;
END CHECK$CONTINUATION;
/*
**********************************************************
* *
* ERROR IS THE COMPILER ERROR HANDLING ROUTINE *
* IF AN ERROR IS DETECTED WHILE PARSING A STATEMENT *
* THE REMAINDER OF THE STATEMENT IS SKIPPED AND THE *
* STATEMENT IS WRITTEN ON THE CONSOLE FOLLOWED BY A *
* TWO LETTER DISCRIPTION OF THE ERROR. AN UP ARROR *
* INDICATES WHERE IN THE LINE THE ERROR WAS DETECTED *
* THE PARSER IS RESET AND COMPILATION CONTINUES WITH *
* THE NEXT STATEMENT. *
* *
**********************************************************
*/
ERROR: PROCEDURE(ERRCODE) PUBLIC;
DECLARE
ERRCODE ADDRESS,
POINTER BYTE;
POINTER = LINEPTR + 2;
IF PASS2 THEN
ERRSET = TRUE; /* SO SOURCE LINE WILL BE LISTED */
IF TOKEN <> TCR THEN
DO; /* SKIP REMAINDER OF LINE */
DO WHILE NEXTCHAR <> EOLCHAR;
CALL CHECK$CONTINUATION;
NEXTCHAR = GETCHAR;
END;
CALL GET$NO$BLANK;
END;
IF PASS2 THEN
DO; /* PRINT ERROR MESSAGE */
ERRORCOUNT = ERRORCOUNT + 1;
CALL PRINTCHAR(HIGH(ERRCODE));
CALL PRINTCHAR(LOW(ERRCODE));
CALL PRINTCHAR(QUESTIONMARK);
DO WHILE(POINTER:=POINTER - 1) >= 1;
CALL PRINTCHAR(' ');
END;
CALL PRINTCHAR(UPARROW);
CALL CRLF;
END;
ERRSET, COMPILING = FALSE;
CALL SETFLAGS;
RETURN;
END ERROR;
/*
*********************************************************
* *
* INITIALIZE$SCANNER SETS NEXTCHAR TO THE FIRST *
* NON-BLANK CHARACTER ON THE INPUT FILE AND *
* INITIALIZES THE OUTPUTLINE COUNTER AND POINTER *
* *
* INITIALIZE$SCANNER IS CALLED AT THE BEGINNING OF *
* PASS ONE AND PASS TWO. *
* *
*********************************************************
*/
IN$SCANNER: PROCEDURE PUBLIC;
DECLARE COUNT BYTE;
DECLARE I BYTE;
IF PASS1 THEN /* GET PARAMETER LIST */
CALL MOVE(PARMS,.PARMLIST,8); /* LAST BLANK IS LEFT UNFILLED */
CALL OPEN$SOURCEFILE;
CONT,COLUMN,LINENO,LINEPTR = 0;
CALL CLEAR$LINE$BUFF;
SOURCEPTR = SOURCERECSIZE;
SEPARATOR = COLIN;
CALL GETNOBLANK;
IF PARMLIST(0) = '$' THEN
DO; I = 0;
DO WHILE (COUNT := PARMLIST(I:=I+1)) <> ' ';
IF(COUNT := COUNT - 'A') <= 5 THEN
DO CASE COUNT;
LISTPROD = TRUE;
LISTSOURCE = FALSE;
NOINTFILE = TRUE;
LOWERTOUPPER = FALSE;
DEBUGLN = TRUE;
LSTFLAG = TRUE;
END; /* OF CASE */
END;
END;
END IN$SCANNER;
/*
*********************************************************
* *
* THE SCANNER ACCEPTS INPUT CHARACTERS FROM THE *
* SOURCE FILE RETURNING TOKENS TO THE PARSER. *
* CONVERSION TO UPPERCASE IS PERFORMED WHEN SCAN- *
* NING IDENTIFIERS UNLESS LOWERTOUPPER IS FALSE. *
* BLANKS ARE IGNORED. EACH TOKEN IS PLACED IN *
* ACCUM. ACCLEN IS THE LENGTH OF THE TOKEN. *
* THE TOKEN IS HASHCODED BY SUMMING EACH ASCII *
* CHARACTER MODULO HASHTBLSIZE AND THE RESULT IS *
* RETURNED IN HASHCODE. SUBTYPE AND FUNCOP ARE *
* SET IF THE TOKEN IS A PREDEFINED FUNCTION. *
* REM AND DATA STATEMENTS ARE HANDLED COMPLETELY *
* BY THE SCANNER. IF THE RESERVED WORD REM OR *
* REMARK IS DETECTED THE INPUT IS SCANNED UNTIL *
* THE END OF THE CURRENT INPUT LINE IS LOCATED. *
* THE NEXT TOKEN (A CARRIAGE RETURN) IS THEN *
* SCANNED AND RTURNED. DATA STATEMENTS ARE SIMILAR *
* EXCEPT THE DATA IS WRITTEN OUT USEING EMITDAT *
* *
*********************************************************
*/
SCANNER: PROCEDURE PUBLIC;
/*
**********************************************************
* *
* THE FOLLOWING UTILITY PROCEDURES ARE USED BY THE *
* SCANNER. *
* *
**********************************************************
*/
PUTINACCUM: PROCEDURE;
IF NOT CONT THEN
DO;
ACCUM(ACCLEN := ACCLEN + 1) = NEXTCHAR;
HASHCODE = (HASHCODE + NEXTCHAR) AND HASHMASK;
IF ACCLEN >= (IDENTSIZE - 1) THEN
CONT = TRUE;
END;
RETURN;
END PUTINACCUM;
PUTANDGET: PROCEDURE;
CALL PUTINACCUM;
CALL GETNOBLANK;
RETURN;
END PUTANDGET;
PUTANDCHAR: PROCEDURE;
CALL PUTINACCUM;
NEXTCHAR = GETCHAR;
RETURN;
END PUTANDCHAR;
NUMERIC: PROCEDURE BYTE;
RETURN(NEXTCHAR - '0') <= 9;
END NUMERIC;
LOWERCASE: PROCEDURE BYTE;
RETURN (NEXTCHAR >= 61H) AND (NEXTCHAR <= 7AH);
END LOWER$CASE;
DECIMALPT: PROCEDURE BYTE;
RETURN NEXTCHAR = '.';
END DECIMALPT;
CONV$TO$UPPER: PROCEDURE;
IF LOWERCASE AND LOWERTOUPPER THEN
NEXTCHAR = NEXTCHAR AND 5FH;
RETURN;
END CONV$TO$UPPER;
LETTER: PROCEDURE BYTE;
CALL CONV$TO$UPPER;
RETURN ((NEXTCHAR - 'A') <= 25) OR LOWERCASE;
END LETTER;
ALPHANUM: PROCEDURE BYTE;
RETURN NUMERIC OR LETTER OR DECIMALPT;
END ALPHANUM;
SPOOLNUMERIC: PROCEDURE;
DO WHILE NUMERIC;
CALL PUTANDCHAR;
END;
RETURN;
END SPOOLNUMERIC;
SETUP$NEXT$CALL: PROCEDURE;
IF NEXTCHAR = ' ' THEN
CALL GETNOBLANK;
CONT = FALSE;
RETURN;
END SETUP$NEXT$CALL;
EMITDAT: PROCEDURE(OBJCODE);
/*
WRITES DATA STATEMENTS DURING PASS2 AND
COUNTS SIZE OF DATA AREA.
*/
DECLARE OBJCODE BYTE;
DATACT = DATACT + 1;
IF PASS2 THEN
CALL EMIT(OBJCODE);
RETURN;
END EMITDAT;
/*
*********************************************************
* *
* LOOKUP IS CALLED BY THE SCANNER WITH THE *
* PRINTNAME OF THE CURRENT TOKEN IN *
* THE ACCUMULATOR. LOOKUP DETERMINES IF THIS *
* TOKEN IS A RESERVED WORD AND SETS THE *
* VALUE OF TOKEN. IF THE TOKEN IS A PREDEFINED *
* FUNCTION THEN THE SUBTYPE AND FUNCOP ARE ALSO *
* SET. *
* THE RESERVED WORD TABLE IS DIVIDED INTO 7 *
* TABLES FOR RESERVED WORDS OF LENGTH 1 TO 7. *
* THE FOLLOWING VECTORS ARE ALSO USED: *
* TK - TOKEN ASSOCIATED WITH RESERVED WORD *
* OFFSET - INDEX INTO LNG VECTOR FOR A GIVEN *
* R/W LENGTH *
* COUNT - NUMBER OF R/W OF A GIVEN LENGTH *
* TKOS - INDEX INTO TK FOR A GIVEN R/W LENGTH *
* ST - SPECIAL DATA FOR PREDEFINED FUNCTIONS *
* *
* PREDEFINED FUNCTIONS HAVE TOKEN VALUES >64. *
* THIS NUMBER BECOMES THE FUNCOP AND THE TOKEN *
* IS FUNCT. FUNCOP IS THE MACHINE CODE FOR THE *
* PARTICULAR PREDEFINED FUNCTION. *
* *
*********************************************************
*/
LOOKUP: PROCEDURE BYTE;
DECLARE MAXRWLNG LIT '9'; /* MAX LENGTH OF A RESERVED WORD */
DECLARE LNG1(*) BYTE
DATA(EOLCHAR,'<','(','+','*',')','-',',','=','/',
';','>',':',POUNDSIGN,UPARROW), /* 15 */
LNG2(*) BYTE
DATA('IF','TO','GO','ON','OR','EQ','LT','GT',
'LE','GE','NE'), /* 11 */
LNG3(*) BYTE
DATA('FOR','LET','REM','DIM','DEF','NOT','AND',
'TAN','SIN','COS','SQR','TAB','LOG','LEN',
'FRE','ATN','ABS','EXP','INT','END','POS',
'RND','SGN','INP','ASC','VAL','XOR','SUB',
'OUT'),
/* 29 */
LNG4(*) BYTE DATA('THEN','READ','GOTO','ELSE','NEXT',
'STOP','DATA','FILE','CHR$','MID$',
'STEP','STR$','COSH','SINH'), /* 14 */
LNG5(*) BYTE DATA('PRINT','INPUT','GOSUB','CLOSE',
'LEFT$'), /* 5 */
LNG6(*) BYTE DATA('RETURN','RIGHT$','REMARK'), /* 3 */
LNG7(*) BYTE DATA('RESTORE'), /* 1 */
LNG9(*) BYTE DATA('RANDOMIZE'),
TK(*) BYTE DATA(0,TCR,LESST,LPARN,TPLUS,ASTRK,RPARN,TMINUS,
COMMA,EQUAL,SLASH,SCOLN,GTRT,TCOLIN,POUND,
EXPON, /* LNG 1 */
TIF,TTO,TGO,TON,TOR,EQUAL,LESST,GTRT,TLEQ,
TGEQ,TNE, /* LNG2 */
TFOR,TLET,TREM,TDIM,TDEF,TNOT,TAND,
72,69,70,73,74,78,84,76,71,65,75,
66,TEND,79,67,68,80,81,88,TXOR,TSUB,TOUT,
/* LNG 3 */
TTHEN,TREAD,TGOTO,TELSE,TNEXT,TSTOP,TDATA,
TFILE,82,85,TSTEP,87,89,90, /* LNG 4 */
TPRNT,TINPT,TGOSB,TCLOS,83, /* LNG 5 */
TRETN,86,TREM, /* LNG 6 */
TREST,TIRN),
OFFSET(*) BYTE DATA(0,0,15,37,124,180,205,223,230,230),
COUNT(*) BYTE DATA(0,15,11,29,14,5,3,1,0,1),
TKOS(*) BYTE DATA(0,0,15,26,55,69,74,77,78,78),
ST(*) BYTE DATA(1,1,0,1,1,1,1,1,1,1,1,0,0,1,0,1,
5,65,70,5,71,70,65,5,1,1);
DECLARE
PTR ADDRESS,
FIELD BASED PTR (1) BYTE,
I BYTE;
COMPARE: PROCEDURE BYTE;
DECLARE I BYTE;
I = 0;
DO WHILE (FIELD(I) = ACCUM(I := I + 1)) AND I <= ACCLEN;
END;
RETURN I > ACCLEN;
END COMPARE;
IF ACCLEN > MAXRWLNG THEN
RETURN FALSE;
PTR = OFFSET(ACCLEN) + .LNG1;
DO I = 1 TO COUNT(ACCLEN);
IF COMPARE THEN
DO;
IF((TOKEN := TK(TKOS(ACCLEN) + I)) > 64) AND
(TOKEN <> TDATA) THEN
DO;
SUBTYPE = ST(TOKEN - 65);
FUNCOP = TOKEN;
TOKEN = FUNCT;
END;
RETURN TRUE;
END;
PTR = PTR + ACCLEN;
END;
RETURN FALSE;
END LOOKUP;
DO FOREVER; /* TO HANDLE REM, DAT AND CONTINUATION */
ACCLEN, HASHCODE, TOKEN, SUBTYPE = 0;
/* FIRST CASE - IS THIS A STRING OR THE CONTINUATION
OF A STRING? (ONLY STRINGS MAY BE CONTINUED)
*/
IF(NEXTCHAR = STRINGDELIM) OR CONT THEN
DO; /* FOUND STRING */
TOKEN = STRING;
CONT = FALSE;
DO FOREVER; /* ALLOWS "" IN STRING TO BE " */
DO WHILE GETCHAR <> STRINGDELIM;
IF NEXTCHAR = EOLCHAR THEN CALL ERROR('US');
CALL PUTINACCUM;
IF CONT THEN RETURN;
END;
CALL GETNOBLANK;
IF NEXTCHAR <> STRINGDELIM THEN
RETURN;
CALL PUT$IN$ACCUM;
END; /* OF DO FOREVER */
END; /* OF RECOGNIZING A STRING */
/*
NEXT CASE IS A NUMERIC WHICH MUST START WITH A
NUMBER OR WITH A PERIOD
ONLY FIRST IDENTSIZE CHARACTERS ARE RETAINED
*/
ELSE IF NUMERIC OR DECIMALPT THEN
DO; /* HAVE DIGIT */
TOKEN = FLOATPT;
DO WHILE NEXTCHAR = '0'; /* ELIM LEADING ZEROS */
NEXTCHAR = GETCHAR;
END;
CALL SPOOLNUMERIC; /* GET ALL THE NUMBERS */
IF DECIMALPT THEN
DO;
CALL PUTANDCHAR;
CALL SPOOLNUMERIC;
END;
CALL CONV$TO$UPPER;
IF NEXTCHAR = 'E' THEN
DO; /* A FLOATING POINT NUMBER */
CALL PUTANDGET;
IF (NEXTCHAR = '+') OR (NEXTCHAR='-') THEN
CALL PUTANDGET;
IF NOT NUMERIC THEN
CALL ERROR('IF');
CALL SPOOL$NUMERIC;
END;
IF ACCLEN = 0 THEN
HASHCODE, ACCUM(ACCLEN := 1) = '0';
CALL SETUP$NEXT$CALL;
RETURN;
END; /* OF RECOGNIZING NUMERIC CONSTANT */
/*
NEXT CASE IS IDENTIFIER. MAY BE RESERVED WORD
IN WHICH CASE MAY BE REM, OR DATA. THESE STATEMENTS
ARE HANDLED BY THE SCANNER VICE THE PARSER AND THEN
ANOTHER LOOP THROUGH THE SCANNER IS MADE.
ONLY IDENTSIZE-1 CHARACTERS ARE RETAINED
*/
ELSE IF LETTER THEN
DO; /* HAVE A LETTER */
DO WHILE ALPHANUM;
CALL PUTANDCHAR;
END;
IF NEXTCHAR = '$' THEN
DO;
SUBTYPE = STRING;
CALL PUTANDCHAR;
END;
ELSE
SUBTYPE = FLOATPT;
IF NOT LOOKUP THEN
DO;
IF ACCUM(1) = 'F' AND ACCUM(2) = 'N'
AND ACCLEN <> 1 THEN
TOKEN = UDFUNCT;
ELSE
TOKEN = IDENTIFIER;
CALL SETUP$NEXT$CALL;
RETURN;
END;
ELSE /* IS A RW */
IF TOKEN = TREM THEN
DO WHILE NEXTCHAR <> EOLCHAR;
NEXTCHAR = GETCHAR;
CALL CHECK$CONTINUATION;
END;
ELSE
IF TOKEN = TDATA THEN
DO;
DECLARE DAT LIT '51';
CALL EMITDAT(DAT);
CALL EMITDAT(NEXTCHAR);
DO WHILE GETCHAR <> EOLCHAR;
CALL CHECK$CONTINUATION;
CALL EMITDAT(NEXTCHAR);
END;
CALL EMITDAT(',');
CALL EMITDAT(0);
DATACT = DATACT - 1;
END;
ELSE
DO;
CALL SETUP$NEXT$CALL;
RETURN;
END;
END; /* OF RECOGNIZING RW OR IDENT */
/*
LAST CASE IS A SPECIAL CHARACTER - IT MAY BE
THE CONTINUATION CHARACTER IN WHICH CASE JUST
GO TO NEXT LINE AND SCAN SOMEMORE.
*/
ELSE
DO; /* SPECIAL CHARACTER */
IF NEXTCHAR = CONTCHAR THEN
CALL CHECK$CONTINUATION;
ELSE
DO;
CALL PUTANDGET;
IF NOT LOOKUP THEN
CALL ERROR('IC');
RETURN;
END;
END; /* OF RECOGNIZING SPECIAL CHAR */
END; /* OF DO FOREVER */
END SCANNER;
END;

312
ASSEMBLY & COMPILE TOOLS/Basic-E/source/BASPAR.PLM Normal file
View File

@@ -0,0 +1,312 @@
BASPAR:
DO;
/* PARSER MODULE FOR THE BASIC - E COMPILER */
$INCLUDE (:F1:BASCOM.LIT)
/* GLOBAL PROCEDURES */
PRINT: PROCEDURE(A) EXTERNAL;
DECLARE A ADDRESS;
END PRINT;
CRLF: PROCEDURE EXTERNAL;
END CRLF;
IN$SYMTBL: PROCEDURE EXTERNAL;
END IN$SYMTBL;
IN$SCANNER: PROCEDURE EXTERNAL;
END IN$SCANNER;
IN$SYN: PROCEDURE EXTERNAL;
END IN$SYN;
SCANNER: PROCEDURE EXTERNAL;
END SCANNER;
SYNTHESIZE: PROCEDURE(PROD) EXTERNAL;
DECLARE PROD BYTE;
END SYNTHESIZE;
ERROR: PROCEDURE(ERR) EXTERNAL;
DECLARE ERR ADDRESS;
END ERROR;
/* GLOBAL VARIABLES */
DECLARE
/* SCANNER PARAMETERS USED IN PARSING */
TOKEN BYTE EXTERNAL,
SUBTYPE BYTE EXTERNAL,
HASHCODE BYTE EXTERNAL,
ACCLEN BYTE EXTERNAL,
ACCUM(IDENTSIZE) BYTE EXTERNAL,
/* PASS CONTROLS */
LISTSOURCE BYTE EXTERNAL,
(PASS1, PASS2) BYTE EXTERNAL;
/* LOCAL VARIABLES AND PROCEDURES */
INITIALIZE: PROCEDURE;
CALL IN$SYMTBL;
CALL IN$SYN;
CALL IN$SCANNER;
END INITIALIZE;
DECLARE
I INDEXSIZE,
J INDEXSIZE,
K INDEXSIZE,
INDEX BYTE;
GETIN1: PROCEDURE INDEXSIZE;
RETURN INDEX1(STATE);
END GETIN1;
GETIN2: PROCEDURE INDEXSIZE;
RETURN INDEX2(STATE);
END GETIN2;
INCSP: PROCEDURE;
IF (SP := SP + 1) = LENGTH(STATESTACK) THEN
CALL ERROR('SO');
RETURN;
END INCSP;
LOOKAHEAD: PROCEDURE;
IF NOLOOK THEN
DO;
CALL SCANNER;
NOLOOK = FALSE;
END;
RETURN;
END LOOKAHEAD;
SET$VARC$I: PROCEDURE(I);
DECLARE I BYTE;
/* SET VARC AND INCREMENT VARINDEX */
VARC(VARINDEX) = I;
IF (VARINDEX := VARINDEX + 1) > LENGTH(VARC) THEN
CALL ERROR('VO');
END SET$VARC$I;
DECLARE /* PARSE TABLES AND RELATED VARIABLES */
EXTERN LITERALLY 'EXTERNAL',
COMPILING BYTE EXTERN,
STATE STATESIZE EXTERN, /* CURRENT STATE OF FSM */
STATESTACK(PSTACKSIZE) STATESIZE EXTERN,/* HOLDS STATES DURING PARSE */
HASH(PSTACKSIZE) BYTE EXTERN, /* HASH CODE OF CURRENT SYMBOL */
SYMLOC(PSTACKSIZE) ADDRESS EXTERN, /* CURRENT SYMBOL LOCATION */
SRLOC(PSTACKSIZE) ADDRESS EXTERN,
VAR(PSTACKSIZE) BYTE EXTERN, /* INDEX TO VARC */
TYPE(PSTACKSIZE) BYTE EXTERN, /* TYPE OF CURRENT SYMBOL */
STYPE(PSTACKSIZE) BYTE EXTERN, /* SUBTYPE OF CURRENT SYMBOL */
VARC(VARCSIZE) BYTE EXTERN, /* CHARACTERS FOR CURRENT SYMBOL */
VARINDEX BYTE EXTERN, /* CURRENT TOP OF VARC */
SP BYTE EXTERN, /* CURRENT TOP OF STACKS */
MP BYTE EXTERN, /* CURRENT "FRONT" OF PRODUCTIONS */
MPP1 BYTE EXTERN, /* MP + 1 */
NOLOOK BYTE EXTERN; /* TRUE IF NOT LOOKED-AHEAD */
DECLARE MAXRNO LITERALLY '120',/* MAX READ COUNT */
MAXLNO LITERALLY '175',/* MAX LOOK COUNT */
MAXPNO LITERALLY '189',/* MAX PUSH COUNT */
MAXSNO LITERALLY '341',/* MAX STATE COUNT */
STARTS LITERALLY '121',/* START STATE */
PRODNO LITERALLY '152';/* NUMBER OF PRODUCTIONS */
DECLARE READ1(*) BYTE
DATA(0,49,10,13,2,49,50,52,53,54,49,13,22,32,2,3,7,27,30
,49,50,52,53,54,2,3,7,30,49,50,52,53,54,54,52,12,52,2,3,7,49,50,52
,53,54,12,52,49,49,50,2,3,7,12,30,49,50,52,53,54,2,2,2,9,5,9,49,4,8
,49,16,20,28,29,31,35,36,37,38,40,42,43,44,45,46,48,49,51,52,49,14,6
,22,13,52,9,52,9,23,9,21,33,41,16,21,33,36,43,9,21,33,5,9,21,33,5,21
,33,5,9,21,33,5,9,21,33,6,9,21,33,21,33,39,21,33,41,5,21,33,6,21,33
,9,6,9,16,17,20,25,26,27,28,29,31,35,36,37,38,40,42,43,44,45,46,48
,51,52,2,16,20,28,29,31,35,36,37,38,40,42,43,44,45,46,48,51,52,52,13
,24,11,34,9,2,1,3,7,10,13,15,18,19,3,7,9,0);
DECLARE LOOK1(*) BYTE
DATA(0,49,0,10,13,0,13,0,11,23,34,0,52,0,12,52,0,49,50,0,6
,9,11,23,34,0,2,0,2,0,9,0,4,8,0,4,8,0,4,8,0,4,8,0,4,8,0,11,23,34,0
,14,0,14,0,14,0,9,0,9,0,9,0,9,0,9,0,21,33,0,21,33,0,21,33,0,21,33,0
,21,33,39,0,21,33,0,21,33,0,21,33,0,23,0,21,33,0,21,33,0,9,0,9,0,6,9
,0,52,0,11,23,0,11,23,34,0,2,0,11,23,0,52,0,24,0,24,0,11,0,23,0,11,0
,9,0,2,0,1,3,7,10,13,15,18,19,0,3,7,0,9,0);
DECLARE APPLY1(*) BYTE
DATA(0,0,0,0,55,105,0,19,0,0,32,47,0,0,3,4,12,14,16,17,20
,21,22,26,27,34,36,38,40,98,100,102,103,114,116,0,0,46,0,28,0,33,0
,63,0,5,6,8,9,0,7,10,0,23,0,13,19,32,35,47,55,99,101,105,106,0,0,0,0
,0,39,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,11,0,0,0,0,0,0,0,99
,106,0,0,0,0,0,40,0,0,0,0,0,0,62,0,0,74,0,74,0,0,0,0,0,0,0,0,0);
DECLARE READ2(*) ADDRESS DATA
(0,191,264,260,3,255,256,129,254,253,326,258,329,331,3
,5,8,31,33,255,256,129,254,253,3,5,8,33,255,256,129,254,253,279,42
,21,129,3,5,8,255,256,129,254,253,20,129,273,255,256,3,5,8,20,33,255
,256,129,254,253,247,294,4,335,280,283,320,7,10,327,24,26,268,32,34
,285,328,125,126,338,38,330,127,128,337,340,275,341,129,325,23,302
,27,220,130,17,131,13,190,14,223,224,277,24,223,224,328,330,12,223
,224,246,248,223,224,244,223,224,249,252,223,224,293,295,223,224,316
,16,223,224,223,224,36,223,224,37,288,223,224,317,223,224,15,318,319
,24,25,26,29,30,339,268,32,34,285,328,125,126,338,38,330,127,128,337
,340,341,129,251,24,26,268,32,34,285,328,125,126,338,38,330,127,128
,337,340,341,129,45,22,28,124,276,286,282,122,6,9,123,257,259,261
,265,6,9,11,0);
DECLARE LOOK2(*) ADDRESS DATA
(0,1,176,2,2,263,18,262,177,177,177,19,334,333,35,35
,178,39,39,179,180,180,180,180,180,40,41,245,43,181,44,332,49,49,231
,50,50,234,51,51,235,52,52,232,53,53,233,182,182,182,55,57,236,58
,237,59,238,66,308,68,300,69,299,70,301,72,296,76,76,297,77,77,309
,78,78,219,84,84,312,85,85,85,183,87,87,336,88,88,298,89,89,310,278
,91,93,93,313,94,94,269,95,321,96,322,97,97,184,99,185,186,186,101
,314,314,314,102,104,250,187,187,105,106,188,109,221,110,222,111,193
,274,112,113,272,115,284,117,189,118,118,118,118,118,118,118,118,229
,119,119,230,120,290);
DECLARE APPLY2(*) ADDRESS DATA
(0,0,161,71,169,170,168,199,198,200,218,267,201,98,80
,90,151,152,92,155,83,86,154,74,150,75,156,146,147,148,149,153,82,79
,81,73,46,167,166,226,225,228,227,174,173,133,135,134,136,132,139
,140,138,240,239,305,64,64,304,64,64,304,64,64,304,241,114,243,116
,163,60,242,63,202,61,47,266,194,271,164,137,197,172,108,107,204,65
,171,287,196,175,292,291,103,205,145,206,210,165,143,144,142,207,159
,141,307,100,160,162,208,213,56,62,158,157,209,323,48,324,54,203,67
,216,212,211,195,214,215);
DECLARE INDEX1(*) ADDRESS DATA
(0,1,2,24,24,4,4,4,4,4,4,34,24,36,24,10,24,24,11,168
,24,24,24,4,12,14,24,24,24,33,34,35,36,37,24,45,24,47,24,48,50,60,61
,62,63,64,24,36,66,67,67,67,67,67,69,70,89,90,90,90,91,92,89,37,93
,94,95,96,97,97,97,98,99,100,103,108,100,100,100,111,115,118,122,126
,100,130,133,100,100,100,136,100,139,100,100,142,142,143,24,36,24
,145,24,24,167,168,36,186,187,188,188,189,189,189,24,191,24,192,193
,201,203,1,3,6,8,12,14,17,20,26,28,30,32,35,38,41,44,47,51,53,55,57
,59,61,63,65,67,70,73,76,79,83,86,89,92,94,97,100,102,104,107,109
,112,116,118,121,123,125,127,129,131,133,135,137,146,149,192,217,306
,303,311,289,217,270,315,306,217,217,306,281,1,2,2,3,3,3,3,3,4,4,7,7
,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,9,10,13,14,14,36,36,37,37,39,39,41
,41,43,43,43,43,43,45,45,45,50,50,53,53,53,53,55,55,66,66,67,67,68
,68,69,69,70,70,72,72,72,72,72,72,72,72,72,73,74,75,76,76,77,77,77
,78,78,79,80,81,82,83,83,84,84,85,86,86,87,88,88,89,90,90,91,93,93
,94,95,95,96,96,97,98,98,99,99,99,102,102,103,103,103,104,104,105
,105,106,106,108,108,109,110,110,111,112,113,113,115,116,116,118,118
,120,120,121,121,122,123,124,125,126,127);
DECLARE INDEX2(*) BYTE
DATA(0,1,2,9,9,6,6,6,6,6,6,1,9,1,9,1,9,9,1,18,9,9,9,6,2
,10,9,9,9,1,1,1,1,8,9,2,9,1,9,2,10,1,1,1,1,2,9,1,1,2,2,2,2,2,1,19,1
,1,1,1,1,1,1,8,1,1,1,1,1,1,1,1,1,3,5,3,2,2,2,4,3,4,4,4,2,3,3,2,2,2,3
,2,3,2,2,1,1,2,9,1,9,22,9,9,1,18,1,1,1,1,1,1,2,1,9,1,9,1,8,2,1,2,3,2
,4,2,3,3,6,2,2,2,3,3,3,3,3,4,2,2,2,2,2,2,2,2,3,3,3,3,4,3,3,3,2,3,3,2
,2,3,2,3,4,2,3,2,2,2,2,2,2,2,2,9,3,2,1,19,35,39,40,43,55,85,97,99
,101,105,106,117,2,0,0,0,0,0,0,0,0,2,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
,0,0,1,1,1,0,2,0,0,0,2,0,1,0,2,0,2,2,1,1,0,2,2,0,2,0,0,0,2,0,2,1,2,2
,0,1,2,0,0,0,0,0,1,0,1,0,0,0,1,0,3,1,0,1,0,0,1,5,1,1,2,2,3,1,2,0,0,2
,1,0,2,1,2,0,1,0,2,2,1,2,1,0,2,2,1,2,1,0,0,2,0,2,2,0,2,0,0,2,0,0,2,4
,0,0,1,1,1,2,2,0,2,1,0,1,0,1,1,0,0,2,3,0,0,0,0,0);
/*
*********************************************************
* *
* EXECUTION OF THE COMPILER BEGINS HERE *
* *
* THE OUTPUT FILE IS CREATED AND THE *
* SYMBOLTABLE, SYNTHESIZE AND SCANNER *
* ARE INITIALIZED. THEN THE PARSER *
* BEGINS PROCESSING THE SOURCE PROGRAM. *
* PROCESSING CONTINUES UNTIL AN END *
* STATEMENT IS INCOUNTERED OR UNTIL THE *
* END OF THE SOURCE FILE IS DETECTED. *
* AT THIS TIME THE THREE MAIN PROCEDURES *
* ARE INITIALIZED FOR PASS 2 AND THE *
* PARSER PROCESSES THE SOURCE FILE A *
* SECOND TIME. AT THE END OF EACH STATE- *
* MENT (WHICH TO THE PARSER IS A PROGRAM) *
* AND IF AN ERROR IS DETECTED THE PARSER *
* VARIABLES ARE REINITIALIZED BY SETTING *
* COMPILING FALSE. *
* *
*********************************************************
*/
CALL PRINT(.('BASIC-E COMPILER VER 2.1$'));
CALL CRLF;
CALL INITIALIZE; /* INITIALIZE MAJOR SYSTEMS PRIOR TO PARSING */
DO FOREVER; /* THIS LOOP CONTROLS THE 2 PASSES OF THE COMPILER */
DO WHILE (PASS1 OR PASS2);/* THIS LOOP REINITIALIZES ON ERR OR OOC */
/* INITIALIZE VARIABLES */
COMPILING,NOLOOK=TRUE; STATE=STARTS;
SP=255;
VARINDEX, VAR(0) = 0;
DO WHILE COMPILING;
IF STATE <= MAXRNO THEN /* READ STATE */
DO;
CALL INCSP;
STATESTACK(SP) = STATE;
I = GETIN1;
CALL LOOKAHEAD;
J = I + GETIN2 - 1;
DO I = I TO J;
IF READ1(I) = TOKEN THEN /* SAVE TOKEN */
DO;
VAR(SP) = VARINDEX;
DO INDEX = 0 TO ACCLEN;
CALL SET$VARC$I(ACCUM(INDEX));
END;
HASH(SP) = HASHCODE;
STYPE(SP) = SUBTYPE;
STATE = READ2(I);
NOLOOK = TRUE;
I = J;
END;
ELSE
IF I = J THEN
CALL ERROR('NP');
END;
END;
ELSE
IF STATE > MAXPNO THEN /* APPLY PRODUCTION STATE */
DO;
MP = SP - GETIN2;
MPP1 = MP + 1;
CALL SYNTHESIZE(STATE - MAXPNO);
IF COMPILING THEN
DO;
SP = MP;
I = GETIN1;
VARINDEX = VAR(SP);
J = STATESTACK(SP);
DO WHILE (K := APPLY1(I)) <> 0
AND J <> K;
I = I + 1;
END;
IF(STATE := APPLY2(I)) = 0 THEN
COMPILING = FALSE;
END;
END;
ELSE
IF STATE<= MAXLNO THEN /* LOOKAHEAD STATE */
DO;
I = GETIN1;
CALL LOOKAHEAD;
DO WHILE (K := LOOK1(I)) <> 0 AND
TOKEN <> K;
I = I + 1;
END;
STATE = LOOK2(I);
END;
ELSE /* PUSH STATE */
DO;
CALL INCSP;
STATESTACK(SP) = GETIN2;
STATE = GETIN1;
END;
END; /* OF WHILE COMPILING */
END; /* OF WHILE PASS1 OR PASS2 */
LISTSOURCE = TRUE;
CALL INITIALIZE;
PASS2 = TRUE;
END; /* OF DO FOREVER */
END; /* OF PARSER MODULE */

1639
ASSEMBLY & COMPILE TOOLS/Basic-E/source/BASSYN.PLM Normal file
View File

File diff suppressed because it is too large Load Diff

426
ASSEMBLY & COMPILE TOOLS/Basic-E/source/BUILD.PLM Normal file
View File

@@ -0,0 +1,426 @@
BASBUILD:
DO; /* ORIGINALLY ORG'ED AT 2D00H ABOVE INTERP */
/*
********************************************************
* *
* BASIC-E BUILD PROGRAM *
* *
* U. S. NAVY POSTGRADUATE SCHOOL *
* MONTEREY, CALIFORNIA *
* *
* WRITTEN BY GORDON EUBANKS, JR. *
* *
* CPM VERSION 1.3 *
* *
* DECEMBER 1976 *
* *
********************************************************
*/
/*
********************************************************
* *
* THE BUILD PROGRAM GAINS CONTROL WHEN THE *
* RUN TIME MONITOR IS EXECUTED. THE INT FILE *
* FOR THE PROGRAM TO BE EXECUTED IS OPENED *
* AND THE BASIC-E MACHINE IS BUILT. *
* *
* BUILD PERFORMS THE FOLLOWING FUNCTIONS: *
* *
* (1) THE NUMERIC CONSTANTS ARE READ FROM *
* THE INT FILE, CONVERTED TO INTERNAL REP- *
* RESENTATION, AND STORED IN THE FSA. *
* *
* (2) THE SIZE OF THE CODE AREA, DATA AREA *
* AND NUMBER OF PRT ENTRIES ARE READ FROM *
* THE INT FILE. BUILD THEN DETERMINES THE *
* ABSOLUTE ADDRESS OF EACH SECTION OF THE *
* BASIC-E MACHINE. THESE ADDRESSES ARE *
* PASSED TO THE INTERP PROGRAM VIA FIXED *
* ADDRESSES IN THE FLOATING POINT SCRATCH *
* PAD. *
* *
* (3) FINALLY INSTRUCTIONS ARE READ FROM *
* THE FILE AND PLACED IN EITHER THE DATA *
* AREA OR THE CODE AREA. IN THE CASE OF BRS *
* BRC, PRO, CON, AND DEF OPERATORS THE *
* ADDRESS FOLLOWING THE INSTRUCTION IS RE- *
* LOCATED TO REFLECT ACTUAL MACHINE ADDRESSES *
* (MINUS 1 BECAUSE PROGRAM COUNTER GETS *
* INCREMENTED PRIOR TO USE (EXCEPT FOR CON)!!) *
* AFTER (REPEAT AFTER) THE MACHINE HAS BEEN *
* REPOSITIONED BY INTERP. THE END OF THE INT *
* FILE IS INDICATED BY A MACHINE INSTRUCTION *
* 7FH. *
* REPOSITIONED BY INTERP. *
* *
********************************************************
*/
/*
********************************************************
* *
* GLOBAL LITERALS *
* *
********************************************************
*/
DECLARE
LIT LITERALLY 'LITERALLY',
TRUE LIT '1',
FALSE LIT '0',
CR LIT '0DH',
LF LIT '0AH';
/*
********************************************************
* *
* SYSTEM PARAMETERS WHICH MAY *
* REQUIRE MODIFICATION BY USERS *
* *
********************************************************
*/
DECLARE
/* OP CODES FOR BASIC-E MACHINE INSTRUCTIONS */
DAT LIT '51',
ILS LIT '28',
DEF LIT '94',
BRS LIT '54',
BRC LIT '55',
PRO LIT '30',
CON LIT '46';
/*
********************************************************
* *
* EXTERNAL ENTRY POINTS *
* THESE ENTRY POINTS ALLOW INTERFACEING WITH CP/M *
* *
********************************************************
*/
DECLARE
BDOSBEGIN ADDRESS INITIAL(06H), /* PTR TO BOTTOM CP/M */
MAX BASED BDOSBEGIN ADDRESS,
/* OFFSET IS THE SIZE OF THIS MODULE */
OFFSET ADDRESS EXTERNAL, /* INITIALIZED BELOW */
/* START IS THE ADDRESS TO START INTERPRETATION */
START LABEL EXTERNAL,
/* BEGIN HOLDS THE VALUE OF .MEMORY FOR INTERP */
BEGIN ADDRESS EXTERNAL,
/* PARAMETER PASSING LOCATIONS */
PARAM1 ADDRESS EXTERNAL ,
PARAM2 ADDRESS EXTERNAL ,
PARAM3 ADDRESS EXTERNAL ,
PARAM4 ADDRESS EXTERNAL ;
/*
********************************************************
* *
* GLOBAL VARIABLES *
* *
********************************************************
*/
DECLARE
MCD LIT 'PARAM1',
MDA LIT 'PARAM2',
MPR LIT 'PARAM3',
SB LIT 'PARAM4',
MBASE ADDRESS, /* PTR TO NEXT POSTION IN DATA AREA */
MF BASED MBASE BYTE,
BASE ADDRESS, /* PTR TO NEXT POSITION IN CODE AREA */
CURCHAR BYTE, /* HOLDS CHAR BEING ANALYZED */
B BASED BASE BYTE,
BV BASED BASE(1) BYTE, /* VECTOR VERSION OF B */
A BASED BASE ADDRESS,
AP BYTE, /* ACCUMULATOR INDEX */
ACCUM(16) BYTE, /* HOLDS CONSTANTS PRIOR TO CONV */
TEMP ADDRESS,
T BASED TEMP BYTE;
/*
********************************************************
* *
* FLOATING POINT INTERFACE ROUTINES *
* *
********************************************************
*/
FLTOP: PROCEDURE(FUNCTION,LOCATION) EXTERNAL;
DECLARE FUNCTION BYTE, LOCATION ADDRESS;
END FLTOP;
DECLARE FPN LITERALLY 'FLTOP';
FLTRET: PROCEDURE(FUNCTION,LOCATION) EXTERNAL;
DECLARE FUNCTION BYTE, LOCATION ADDRESS;
END FLTRET;
DECLARE FP LITERALLY 'FLTRET';
FLTINP: PROCEDURE(COUNT,LOCATION) EXTERNAL;
DECLARE COUNT BYTE, LOCATION ADDRESS;
END FLTINP;
DECLARE FPINP LITERALLY 'FLTINP';
/*
********************************************************
* *
* CP/M INTERFACE ROUTINES *
* *
********************************************************
*/
DECLARE
DISKBUFFLOC LIT '80H',
FCBLOC LIT '5CH',
DISKBUFFEND LIT '100H',
/* IF OPERATING SYSTEM READS VARIABLE LENGTH RECORDS
THIS MUST BE ADDRESS OF ACTUAL END OF RECORD */
BUFF ADDRESS INITIAL(DISKBUFFEND), /* INPUT BUFFER */
CHAR BASED BUFF BYTE, /* INPUTBUFF POINTER */
FILENAME ADDRESS INITIAL (FCBLOC),
FNP BASED FILENAME(33) BYTE; /* FILE CONTROL BLK */
MON1:PROCEDURE(FUNCTION,PARAMETER) EXTERNAL;
DECLARE
FUNCTION BYTE,
PARAMETER ADDRESS;
END MON1;
MON2: PROCEDURE(FUNCTION,PARAMETER) BYTE EXTERNAL;
DECLARE
FUNCTION BYTE,
PARAMETER ADDRESS;
END MON2;
MON3: PROCEDURE EXTERNAL;
END MON3;
PRINTCHAR: PROCEDURE(CHAR) EXTERNAL;
DECLARE CHAR BYTE;
END PRINTCHAR;
PRINT: PROCEDURE(BUFFER) EXTERNAL;
/*
PRINT A LINE ON CONSOLE FOLLOWED BY A
CARRIAGE RETURN AND LINEFEED
*/
DECLARE
BUFFER ADDRESS;
END PRINT;
PRINTF: PROCEDURE(BUFFER);
DECLARE BUFFER ADDRESS;
CALL PRINT(BUFFER);
CALL PRINTCHAR(CR); CALL PRINTCHAR(LF);
END PRINTF;
OPEN$INT$FILE: PROCEDURE;
FNP(9) = 'I';
FNP(10) = 'N';
FNP(11) = 'T';
IF MON2(15,FILENAME) = 255 THEN
DO;
CALL PRINTF(.('NI $'));
CALL MON3;
END;
END OPEN$INT$FILE;
READ$INT$FILE: PROCEDURE BYTE;
/*
NEXT RECORD IS READ FROM INT FILE
DISKBUFFEND MUST REFLECT THE ADDRESS
OF THE END OF THE RECORD PLUS ONE
FOR FIXED SIZE RECORDS THIS IS A CONSTANT
RETURNS ZERO IF READ IS SAT, AND 1 IF EOF
*/
RETURN MON2(20,FILENAME);
END READ$INT$FILE;
/*
********************************************************
* *
* GLOBAL PROCEDURES *
* *
********************************************************
*/
INCBUF: PROCEDURE;
IF(BUFF := BUFF + 1) >= DISKBUFFEND THEN
DO;
BUFF = DISKBUFFLOC;
IF READ$INT$FILE <> 0 THEN
CHAR = 7FH;
END;
END INCBUF;
STO$CHAR$INC: PROCEDURE;
/*
GET NEXT CHAR FROM INT FILE AND
PLACE IN CODE AREA. THEN INCREMENT
PTR INTO CODE AREA.
*/
B=CHAR;
BASE=BASE+1;
END STO$CHAR$INC;
NEXT$CHAR: PROCEDURE BYTE;
CALL INCBUF;
RETURN CURCHAR := CHAR;
END NEXT$CHAR;
GET$TWO$BYTES: PROCEDURE;
/*
GET NEXT TWO BYTES FROM THE INT FILE
AND PLACE THEM IN THE CODE AREA IN REVERSE ORDER.
*/
BV(1) = NEXT$CHAR;
B = NEXT$CHAR;
RETURN;
END GET$TWO$BYTES;
INC$BASE$TWO: PROCEDURE;
BASE = BASE + 1 + 1;
RETURN;
END INC$BASE$TWO;
GETPARM: PROCEDURE ADDRESS;
/*
READ A 16 BIT PARAMETER FROM INT FILE
AND CONVERT IT TO AN 8080 ADDRESS QUANTITY
*/
RETURN SHL(DOUBLE(NEXT$CHAR),8) + NEXT$CHAR;
END GETPARM;
/*
********************************************************
* *
* EXECUTION BEGINS HERE *
* *
********************************************************
*/
BUILD:
CALL PRINTF(.('BASIC-E INTERPRETER - VER 2.2$'));
CALL OPEN$INT$FILE;
BASE = (.MEMORY + 100H) AND 0FF00H; /* BEGINNING OF MACHINE AND FDA */
OFFSET = BASE - BEGIN; /* SIZE OF THE BUILD MODULE */
CALL FPN(0,0); /* INITIALIZE FLOATING POINT PACKAGE */
/*
PROCESS CONSTANTS
EACH CONSTANT IS SEPARATED BY A $
LAST CONSTANT FOLLOWED BY A *
*/
DO WHILE(ACCUM(0) := NEXT$CHAR) <> '*'; /* * INDICATES END OF CONST */
AP = 0; /* COUNTER FOR LENGTH OF THIS CONSTANT */
DO WHILE(ACCUM(AP:=AP+1) := NEXT$CHAR) <> '$';
/* GET CONSTANT INTO THE ACCUM */
END;
CALL FPINP(AP,.ACCUM); /* CONVERT IT TO INTERNAL FORM */
CALL FP(9,BASE); /* LOAD INTO FDA FROM F/P ACCUM */
BASE = BASE + 4; /* NEXT LOCATION */
END; /* OF LOOKING FOR * */
/*
SETUP MACHINE ADDRESS
BASE WILL NOW BE NEXT POSITION IN CODE AREA
MBASE WILL BE NEXT POSTION IN DATA AREA
ACTUAL ADDRESSES OF CODE AREA, DATA AREA
PRT, AND STACK ARE PASSED TO INTERPRETER
USING FIXED LOCATIONS
*/
MBASE = GETPARM + BASE;
MDA = MBASE - OFFSET; /* ACTUAL DATA AREA ADDR */
MCD = BASE - OFFSET; /* ACTUAL CODE AREA ADDR */
MPR = GETPARM + MDA; /* ACTUAL BEGINNING OF PRT */
IF MPR >= MAX THEN /* INSURE THERE IS ENOUGH MEMORY */
DO;
CALL PRINTF(.('NM $'));
CALL MON3;
END;
SB = SHL(GETPARM,2) + MPR; /* NUMBER OF ENTRIES IN PRT * 4=SIZE PRT */
/*
BUILD MACHINE - ATLAST
AS OPCODES ARE READ THEY MAY BE:
(1) DAT - WHICH MEANS ALL CHARACTERS
FOLLOWING DAT GO INTO DATA AREA UNTIL
A BINARY ZERO IS INCOUNTERED
(2) GREATER THAN 127 - WHICH IS A LIT
OR A LIT. TREAT THIS AS 16 BIT OPCODE
AND PUT IN CODE AREA IN ORDER THEY ARE
ON INT FILE
(3) ILS - WHICH MEANS ALL CHARACTERS
FOLLOWING GO INTO CODE AREA UNTIL A
BINARY ZERO IS INCOUNTERED - BUT FIRST
PUT A ILS IN CODE AREA AND THE NEXT
BYTE IS SET TO ZERO AND INCREMENTED
FOR EACH CHARACTER IN THE STRING. IE
A STRING CONSTANT IS A ILS OPCODE,
A LENGTH AND THE STRING.
(4) A NORMAL OP CODE - PUT IN CODE
AREA - BUT IF IT IS A BRS OR BRC OR
DEF OR PRO THEN THE NEXT TWO BYTES
ARE AN ADDRESS WHICH MUST BE RELOCATED
TO THE ACTUAL CODE AREA MINUS 1;
OR IT COULD BE A CON WHICH IS
RELOCATED TO THE FDA.
*/
DO WHILE NEXT$CHAR <> 7FH; /* BUILD MACHINE */
IF CURCHAR = DAT THEN /* PROCESS DATA STATEMENT */
DO WHILE(MF := NEXT$CHAR) <> 0; /* LOOK FOR END */
MBASE = MBASE + 1;
END;
ELSE
IF CURCHAR >= 128 THEN /* PROCESS LIT OR LID */
DO;
CALL STO$CHAR$INC;
CALL INCBUF;
CALL STO$CHAR$INC;
END;
ELSE
IF CURCHAR = ILS THEN /* PROCESS INLINE STRING */
DO;
CALL STO$CHAR$INC;
TEMP = BASE;
CHAR = 0; /* TO SET LENGTH TO 0 INITIAL */
CALL STO$CHAR$INC;
DO WHILE NEXT$CHAR <> 0;
CALL STO$CHAR$INC;
T = T + 1;
END;
END;
ELSE
DO;
CALL STO$CHAR$INC;
IF (CURCHAR = BRS) OR (CURCHAR = BRC) OR
(CURCHAR = DEF) OR (CURCHAR = PRO) THEN
DO;
CALL GET$TWO$BYTES;
A = A + MCD - 1;
CALL INC$BASE$TWO;
END;
ELSE
IF CURCHAR = CON THEN
DO;
CALL GET$TWO$BYTES;
A = SHL(A,2) + BEGIN;
CALL INC$BASE$TWO;
END;
END;
END; /* LOOKING FOR 7FH */
GO TO START; /* RETURNS TO BASE MODULE FOR FURTHER PROCESSING */
END;

304
ASSEMBLY & COMPILE TOOLS/Basic-E/source/FPCONV.SRC Normal file
View File

@@ -0,0 +1,304 @@
NAME FPCNV
CSEG
PUBLIC FFLOAT,FFIX,FINP,FOUT
EXTRN FSTOR,FZERO,FABS,FTEST,FLOAD,FMUL
EXTRN FDIV,FADD,ADD10,LSH,RSH,FCOMP
EXTRN OVER,ACCE,ACCS,ACC1,ACC2,ACC3,SF
EXTRN FTEN,RND0
EXTRN ADRL,ADRH,TMP1,TMP2,TMP3,VALE,VAL1,VAL2,VAL3,TMP4
; 8080 BINARY FLOATING POINT SYSTEM
; FORMAT CONVERSION PACKAGE
; PROGRAMMER CAL OHME
; DATE 26 DECEMBER 1973
; SUBROUTINE TO CONVERT FROM FIXED
; POINT TO FLOATING POINT FORMAT.
FFLOAT: MOV L,E; INPUT EXPONENT
MOV E,D; 4TH INPUT FRACTION
MOV D,C; 3RD INPUT FRACTION
MOV C,B; 2ND INPUT FRACTION
MOV B,A; 1ST INPUT FRACTION
MOV A,L; INPUT EXPONENT
XRI 80H; APPLY EXPONENT BIAS
LXI H,ACCE; TO ADDR ACCUM EXPONENT
MOV M,A; ACCUMULATOR EXPONENT
INR L; TO ADDRESS ACCUM SIGN
MVI M,80H; SET ACCUM SIGN POSITIVE
INR L; TO ADDR ACCUM 1ST FRCTN
MOV A,B; 1ST INPUT FRACTION
ANA A ; SET SIGN BIT
RAL ; INPUT SIGN TO CARRY
JMP ADD10; COMPLETE CONVERSION
; SUBROUTINE TO CONVERT FROM FLOATING
; POINT TO FIXED POINT FORMAT.
FFIX: LXI H,ACCE; TO ADDRESS SCRATCH BANK
MOV A,M; ACCUMULATOR EXPONENT
ANA A ; SET CONTROL BITS
JZ FIX1; IF ACCUMULATOR IS ZERO
MOV A,E; INPUT EXPONENT
ADI 7FH; APPLY BIAS - 1
SUB M; SHIFT COUNT - 1
RC ; RETURN IF ACCUM TOO LARGE
CPI 1FH; COMPARE TO LARGE SHIFT
JNC FIX1; IF ACCUMULATOR TOO SMALL
ADI 1; SHIFT COUNT
MVI L,LOW(ACC1); TO ADDR ACCUM 1ST FRCTN
MOV B,M; ACCUMULATOR 1ST FRACTION
INR L; TO ADDR ACCUM 2ND FRCTN
MOV C,M; ACCUMULATOR 2ND FRCTN
INR L; TO ADDR ACCUM 3RD FRCTN
MOV D,M; ACCUMULATOR 3RD FRCTN
CALL RSH; POSITION THE FRACTION
MVI L,LOW(ACCS); TO ADDR ACCUM SIGN
MOV A,M; ACCUMULATOR SIGN
ANA A ; SET CONTROL BITS
CP FCOMP; COMPLEMENT FRCTN IF NEG
MVI A,1; NON-ZERO
ORA B; SET CONTROL BITS FOR EXIT
MOV A,B; 1ST RESULT
MOV B,C; 2ND RESULT
MOV C,D; 3RD RESULT
MOV D,E; 4TH RESULT
RET ; RETURN TO CALLER
FIX1: XRA A; ZERO
MOV B,A; ZERO
MOV C,A; ZERO
MOV D,A; ZERO
RET ; RETURN TO CALLER
DB 0; CHECKSUM WORD
; INP SUBROUTINE ENTRY POINT.
; INITIALIZE TEMPORARY STORAGE.
FINP: MOV E,M; FIRST CHARACTER OF STRING
CALL SVAD; SET CHAR ADDR, PNT FLG, EXP
INR L; TO ADDRESS VALUE SIGN
MVI M,80H; SET VALUE SIGN POSITIVE
LXI H,ACCE; TO ADDR ACCUM EXPONENT
MOV M,D; SET ACCUM TO ZERO
MOV A,E; FIRST CHARACTER
CPI 0F0H; COMPARE TO SPACE
JZ INP1; IF SPACE CHARACTER
CPI 0FBH; COMPARE CHAR TO PLUS
JZ INP1; IF PLUS SIGN
CPI 0FDH; COMPARE TO MINUS
JNZ INP2; IF NOT MINUS SIGN
LXI H,TMP3; TO ADDR VALUE SIGN
MOV M,D; SET VALUE SIGN NEGATIVE
; ANALYZE NEXT CHARACTER IN STRING.
INP1: CALL CHAD; CALL CHAR ADDR SBRTN
MOV A,M; NEXT CHARACTER
INP2: MVI B,0; DIGIT 2ND WD OR DEC EXP
CPI 0FEH; COMPARE TO DECIMAL POINT
JZ INP3; IF DECIMAL POINT
CPI 15H; COMPARE TO EXPONENT SIGN
JZ INP4; IF EXPONENT SIGN
CPI 0AH; SET CARRY IF CHAR IS DIGIT
JNC INP8; IF CHAR IS NOT A DIGIT
LXI H,TMP4; TO ADDR CURRENT DIGIT
MOV M,A; SAVE CURRENT DIGIT
LXI H,FTEN; TO ADDR FLOATING TEN
CALL FMUL; MULTIPLY BY TEN
MVI L,LOW(VALE); TO ADDR VALUE
CALL FSTOR; STORE OLD VALUE TIMES TEN
INR L; TO ADDR CURRENT DIGIT
MOV A,M; CURRENT DIGIT
MVI B,0; CLEAR 2ND WORD OF DIGIT
MOV C,B; CLEAR 3RD WORD OF DIGIT
MOV D,B; CLEAR 4TH WORD OF DIGIT
MVI E,8; INDICATE DIGIT IS IN REG A
CALL FFLOAT; CONVERT DIGIT TO FLOATING PNT
MVI L,LOW(VALE); TO ADDR VALUE
CALL FADD ; ADD OLD VALUE TIMES TEN
MVI L,LOW(TMP2); TO ADDR DEC PNT FLAG
MOV A,M; DECIMAL POINT FLAG
ANA A ; SET CONTROL BITS
JZ INP1; IF NO DEC PNT ENCOUNTERED
DCR L; TO ADDR INPUT EXPONENT
MOV B,M; INPUT EXPONENT
DCR B; DECREMENT INPUT EXPONENT
MOV M,B; UPDATE INPUT EXPONENT
JMP INP1; TO GET NEXT CHARACTER
INP3: LXI H,TMP2; TO ADDR DEC PNT FLAG
XRA M; ZERO IF FLAG SET
MOV M,A; SET DEC PNT FLAG
JNZ INP1; IF FLAG NOT ALREADY SET
JMP INP8; IF 2ND DEC PNT
; PROCESS DECIMAL EXPONENT.
INP4: CALL CHAD; CALL CHAR ADDR SBRTN
MOV A,M; NEXT CHARACTER OF STRING
MOV B,A; CURRENT CHARACTER
SUI 0FDH; COMPARE TO MINUS CHAR
MOV E,A; CHAR - MINUS SIGN
JZ INP5; IF MINUS SIGN
ADI 2; COMPARE TO PLUS CHAR
MOV A,B; CURRENT CHARACTER
JNZ INP6; IF NOT PLUS SIGN
INP5: INR L; TO ADDRESS NEXT CHAR
MOV A,M; NEXT CHARACTER OF STRING
INP6: MVI B,0; POSSIBLE DEC EXPONENT
CPI 0AH; SET CARRY IF CHAR IS DIGIT
JNC INP8; IF CHAR IS NOT A DIGIT
MOV B,A; DEC EXP EQUAL DIGIT
INR L; TO ADDRESS NEXT CHAR
MOV A,M; NEXT CHARACTER OF STRING
CPI 0AH; SET CARRY IF CHAR IS DIGIT
JNC INP7; IF CHAR IS NOT A DIGIT
; FORM COMPLETE DECIMAL EXPONENT.
MOV C,A; LS DIGIT OF DEC EXP
MOV A,B; MS DIGIT OF DEC EXP
ADD A; 2 * MS DIGIT
ADD A; 4 * MS DIGIT
ADD B; 5 * MS DIGIT
ADD A; 10 * MS DIGIT
ADD C; 10 * MS + LS DIGIT
MOV B,A; DECIMAL EXPONENT
INP7: MOV A,E; SIGN OF DEC EXPONENT
ANA A ; SET CONTROL BITS
JNZ INP8; IF SIGN PLUS
SUB B; COMPLEMENT DEC EXP
MOV B,A; DECIMAL EXPONENT
INP8: LXI H,TMP3; TO ADDRESS SCRATCH BANK
MOV C,M; INPUT SIGN
LXI H,ACCS; TO ADDRESS ACCUM SIGN
MOV M,C; ACCUMULATOR SIGN
MOV A,B; DECIMAL EXPONENT
; CONVERT DECIMAL EXPONENT TO BINARY.
INP9: LXI H,TMP1; TO ADDRESS DEC EXPONENT
ADD M; ADJUST DECIMAL EXPONENT
JZ FTEST; IN DEC EXP IS ZERO
MOV M,A; CURRENT DECIMAL EXPONENT
LXI H,FTEN; TO ADDR FLOATING TEN
JP INP10; IF MULTIPLY REQUIRED
CALL FDIV; DIVIDE BY TEN
MVI A,1; TO INCREMENT DEC EXP
JMP INP9; TO TEST FOR COMPLETION
INP10: CALL FMUL; MULTIPLY BY TEN
RC ; RETURN IF OVERFLOW
MVI A,0FFH; TO DECREMENT DEC EXP
JMP INP9; TO TEST FOR COMPLETION
; OUT SUBROUTINE ENTRY POINT.
; SAVE CHARACTER ADDRESS AND ACCUMULATOR.
FOUT: DCR L; DECREMENT CHARACTER ADDRESS
CALL SVAD; SET CHAR ADDR, DIG CNT, DEC EXP
CALL FTEST; LOAD ACCUM TO REGISTERS
LXI H,VALE; TO ADDR ACCUM SAVE AREA
CALL FSTOR; CALL REG STR SUBROUTINE
; OUTPUT SIGN CHARACTER.
CALL CHAD; CALL CHAR ADDR SBRTN
MVI M,0F0H; STORE SPACE CHARACTER
ANA A ; SET CONTROL BITS
JZ OUT3; IF ACCUMULATOR IS ZERO
MOV E,A; ACCUMULATOR EXPONENT
MOV A,B; ACCUM SIGN AND 1ST FRCTN
ANA A ; SET CONTROL BITS
MOV A,E; ACCUMULATOR EXPONENT
JP OUT1; IF ACCUM IS POSITIVE
MVI M,0FDH; CHANGE SIGN TO MINUS
; SCALE ACCUMULATOR TO .1 - 1. RANGE.
OUT1: CPI 7EH; COMPARE TO SMALL EXPONENT
OUT2: LXI H,FTEN; TO ADDR FLOATING TEN
JC OUT4; IF EXPONENT TOO SMALL
CPI 81H; COMPARE TO LARGE EXP
JC OUT5; IF EXP SMALL ENOUGH
CALL FDIV; DIVIDE BY TEN
OUT3: LXI H,TMP2; TO ADDRESS SCRATCH BANK
MOV E,M; DECIMAL EXPONENT
INR E; INCREMENT DECIMAL EXPONENT
MOV M,E; DECIMAL EXPONENT
JMP OUT2; TO TEST FOR SCALING COMPLETE
OUT4: CALL FMUL; MULTIPLY BY TEN
LXI H,TMP2; TO ADDR DECIMAL EXPONENT
MOV E,M; DECIMAL EXPONENT
DCR E; DECREMENT DECIMAL EXPONENT
MOV M,E; DECIMAL EXPONENT
JMP OUT1; TO TEST FOR SCALING COMPLETE
; ROUND THE VALUE BY ADDING .00000005.
OUT5: CALL FABS; SET ACCUM POSITIVE
LXI H,RND0; TO ADDRESS ROUNDER
CALL FADD; ADD THE ROUNDER
CPI 81H; CHECK FOR OVERFLOW
JNC OUT2; IF EXP TOO LARGE
; SET DIGIT COUNTS.
LXI H,TMP2; TO ADDR DECIMAL EXPONENT
MOV A,M; DECIMAL EXPONENT
MOV E,A; DIGITS BEFORE DEC POINT
CPI 8; COMPARE TO LARGE EXP
JC OUT6; IF EXPONENT IN RANGE
MVI E,1; DIGITS BEFORE DEC POINT
OUT6: SUB E; ADJUST DEC EXPONENT
MOV M,A; DECIMAL EXPONENT
MVI A,7; TOTAL NUMBER OF DIGITS
SUB E; DIGITS AFTER DECIMAL PNT
INR L; TO ADDR 2ND DIGIT CNT
MOV M,A; DIGITS AFTER DECIMAL POINT
DCR E; DECREMENT DIGIT COUNT
MOV A,E; DIGITS BEFORE DEC PNT
; OUTPUT SIGNIFICANT DIGITS.
OUT7: LXI H,TMP1; TO ADDR DIGIT COUNT
ADD M; ADJUST DIGIT COUNT
MOV M,A; NEW DIGIT COUNT
JM OUT8; IF COUNT RUN OUT
LXI H,FTEN; TO ADDR FLOATING TEN
CALL FMUL; MULTIPLY BY TEN
MVI E,8; TO PLACE DIGIT IN REG A
CALL FFIX; CONVERT TO FIXED FORMAT
CALL CHAD; CALL CHAR ADDR SBRTN
MOV M,A; OUTPUT DECIMAL DIGIT
XRA A; CLEAR CURRENT DIGIT
MVI E,8; BINARY SCALING FACTOR
CALL FFLOAT; RESTORE VALUE MINUS DIGIT
MVI A,0FFH; TO ADJUST DIGIT CNT
JMP OUT7; LOOP FOR NEXT DIGIT
OUT8: LXI H,TMP3; TO ADDR 2ND DIGIT CNT
MOV A,M; DIGITS AFTER DECIMAL PNT
MVI M,0FFH; SET 2ND COUNT NEG
ANA A ; SET CONTROL BITS
JM OUT9; IF 2ND COUNT RAN OUT
CALL CHAD; CALL CHAR ADDR SBRTN
MVI M,0FEH; STORE DECIMAL POINT
JMP OUT7; LOOP FOR NEXT DIGIT
OUT9: DCR L; TO ADDR DECIMAL EXP
ANA M ; DECIMAL EXPONENT
JZ OUT13; IF DECIMAL EXPONENT IS ZERO
; OUTPUT DECIMAL EXPONENT.
MVI B,0FBH; PLUS CHARACTER
JP OUT10; IF EXPONENT IS POSITIVE
MVI B,0FDH; CHANGE SIGN TO MINUS
MOV C,A; NEGATIVE EXPONENT
XRA A; ZERO
SUB C; COMPLEMENT EXPONENT
OUT10: MVI C,0FFH; EMBRYO TENS DIGIT
OUT11: MOV D,A; UNITS DIGIT
INR C; INCREMENT TENS DIGIT
SUI 0AH; REDUCE REMAINDER
JNC OUT11; IF MORE TENS
MVI A,15H; EXPONENT SIGN
OUT12: CALL CHAD; CALL CHAR ADDR SBRTN
CALL FSTOR; STORE LAST 4 CHARACTERS
LXI H,VALE; TO ADDRESS ACCUM SAVE AREA
JMP FLOAD; RESTORE ACCUM AND EXIT
; OUTPUT 4 SPACES IF EXPONENT IS ZERO.
OUT13: MVI A,0F0H; SPACE CHARACTER
MOV B,A; SPACE CHARACTER
MOV C,A; SPACE CHARACTER
MOV D,A; SPACE CHARACTER
JMP OUT12; TO STORE CHARACTERS
; SUBROUTINE TO SAVE CHARACTER STRING ADDR.
SVAD: MOV A,L; CHARACTER STRING WORD
MOV B,H; CHARACTER STRING BANK
MVI C,0; INPUT EXP OR DIGIT CNT
MOV D,C; DEC PNT FLAG OR DEC EXP
LXI H,ADRL; TO ADDR CHAR STRING WORD
CALL FSTOR; STORE A, B, C, AND D
RET ; RETURN TO CALLER
; SUBROUTINE TO OBTAIN NEXT CHARACTER ADDR.
CHAD: LXI H,ADRL; TO ADDRESS SCRATCH BANK
MOV E,M; CHARACTER STRING WORD
INR E; TO ADDR NEXT CHARACTER
MOV M,E; UPDATE CHAR STRING WORD
INR L; TO ADDR CHAR STRING BANK
MOV H,M; CHARACTER STRING BANK
MOV L,E; CHARACTER STRING WORD
RET ; RETURN TO CALLER
END

80
ASSEMBLY & COMPILE TOOLS/Basic-E/source/FPDATA.SRC Normal file
View File

@@ -0,0 +1,80 @@
; DATA SEGMENT
CSEG INPAGE
PUBLIC IDVT
PUBLIC FSQRN,FSQRX
PUBLIC FMACX,FMACS,FMACT,FMACG
PUBLIC FSINX
PUBLIC FATNT,FATNU
PUBLIC FCSHD
PUBLIC FSNHD,FEXOV,FSNHX
PUBLIC FLOGE,FLOGX
PUBLIC SEED
PUBLIC ACCUM
;
PUBLIC FONE,FPIV2,FLN2,FTEN,RND0
;
; FPPKG VARIABLES
PUBLIC OVER,PREX,ACCE,ACCS,ACC1,ACC2,ACC3,SF
; FPCONV VARIABLES
PUBLIC ADRL,ADRH,TMP1,TMP2,TMP3,VALE,VAL1,VAL2,VAL3,TMP4
;
;
IDVT EQU T00
FSQRN EQU T00
FSQRX EQU T04
FMACX EQU T00
FMACS EQU T04
FMACT EQU T08
FMACG EQU T0C
FSINX EQU T10
FATNT EQU T10
FATNU EQU T14
FCSHD EQU T0E
FSNHD EQU T0E
FEXOV EQU T0F
FSNHX EQU T10
FLOGE EQU T0E
FLOGX EQU T10
;
; VARIABLES FOR FLOATING POINT PACKAGE
OVER: DS 1
PREX: DS 1
ACCE: DS 1
ACCS: DS 1
ACC1: DS 1
ACC2: DS 1
ACC3: DS 1
SF: DS 1
;
; VARIABLES FOR FLOATING POINT CONVERSION
ADRL: DS 1
ADRH: DS 1
TMP1: DS 1
TMP2: DS 1
TMP3: DS 1
VALE: DS 1
VAL1: DS 1
VAL2: DS 1
VAL3: DS 1
TMP4: DS 1
ACCUM: DS 31 ;WORKING BUFFER
;
; VARIABLES FOR TRANSCENDENTAL FUNCTIONS, RANDOM NUMBER GEN
T00: DS 4
T04: DS 4
T08: DS 4
T0C: DS 2
T0E: DS 1
T0F: DS 1
T10: DS 4
T14: DS 4
SEED: DS 2 ;RANDOM NUMBER SEED
;
FONE: DB 81H,0,0,0 ;1.0
FPIV2: DB 81H,49H,0FH,0DCH;PI/2
FLN2: DB 80H,31H,72H,18H ;LN 2
FTEN: DB 84H,20H,0,0 ;10.0
RND0: DB 68H,56H,0BFH,0ADH ;.00000005
;
END

315
ASSEMBLY & COMPILE TOOLS/Basic-E/source/FPINT.SRC Normal file
View File

@@ -0,0 +1,315 @@
NAME FPINT ;FLOATING POINT INTERFACE PACKAGE
CSEG ;CODE SEGMENT
;
; NOTE: THE JMP 0000 TO BUILD MUST BE PATCHED
; JMP 0000 TO INTERP MUST BE PATCHED
;
;
; EQUATES FOR CP/M SYSTEM
BDOS EQU 0005H ;PRIMARY ENTRY POINT TO CP/M
BOOT EQU 0000H ;REBOOT ENTRY POINT
;
; PUBLIC SYMBOLS FOR MAIN PROGRAM
;
PUBLIC BEGIN,START ;BEGINNING OF BUILD, START OF INTERP
PUBLIC MON1 ;FUNC,PARM INPUT, NO OUTPUT
PUBLIC MON2 ;FUNC,PARM INPUT, BYTE OUTPUT
PUBLIC MON3 ;SYSTEM REBOOT
;
PUBLIC MOVEA ;.SOURCE,DEST,N, MOVES BYTES
PUBLIC MOVE4 ;SOURCE,DEST, MOVES 4 BYTES
;
PUBLIC CBIN ;CONVERT TO BINARY
PUBLIC CFLT ;CONVERT TO FLOAT
PUBLIC FLTINP ;FLOATING POINT INPUT
PUBLIC FLTOUT ;FLOATING POINT OUTPUT
PUBLIC FPOUT ;EQUIVALENT TO FLTOUT
PUBLIC FLTRET ;FLOATING POINT OPERATOR RETURN
PUBLIC FLTOP ;FLOATING POINT OPERATOR
;
; SPECIAL PURPOSE SUBROUTINES
PUBLIC INPUT ;PORT, RETURNS BYTE
PUBLIC OUTPUT ;PORT, BYTE
PUBLIC RANDOM
;
; EXTERNAL SYMBOLS
EXTRN FSTOR,FLOAD,FADD,FSUB,FMUL,FDIV,FABS,FZERO,FTEST,FCHS
EXTRN OVER
EXTRN FINP,FOUT,FFLOAT,FFIX
EXTRN FSQRT,FCOS,FSIN,FATAN,FCOSH,FSINH,FEXP,FLOG
EXTRN RAND
EXTRN ACCUM
;
; SUBROUTINES FOR MONITOR INTERFACE
; START OF BASIC COMPILER
JMP 0000 ;PATCHED TO BUILD ENTRY POINT
START:
JMP 0000 ;GO TO THE INTERPRETER
BEGIN: DW 0000 ;FILLED IN WHEN WE FIGURE OUT MEMORY MAP
;
MON1: JMP BDOS
MON2: JMP BDOS
MON3: JMP BOOT
;
; SPECIAL PURPOSE SUBROUTINE ENTRY POINTS
;
; SUBROUTINES FOR STORAGE MOVE OPERATIONS
MOVEA: ;.SOURCE,DESTINATION,COUNT ADDRESSED BY B,C
MOV H,B
MOV L,C
MOV C,M ;LS SOURCE
INX H
MOV B,M ;MS SOURCE
INX H
MOV E,M ;LS DEST
INX H
MOV D,M ;MS DEST
INX H
MOV A,M ;LS COUNT
INX H
MOV H,M ;MS COUNT
MOV L,A ;LS COUNT
; SOURCE IN B,C DEST IN D,E COUNT IN H,L
MOVER: MOV A,L ;CHECK FOR ZERO COUNT
ORA H ;BOTH ZERO?
RZ
; MOVE NEXT BYTE FROM SOURCE TO DESTINATION
DCX H ;COUNT = COUNT - 1
LDAX B ;BYTE TO REGISTER A
STAX D ;TO DESTINATION
INX B ;SOURCE = SOURCE + 1
INX D ;DEST = DEST + 1
JMP MOVER ;FOR THE NEXT BYTE
;
MOVE4: ;SOURCE IN B,C DEST IN D,E
LXI H,4
JMP MOVER
;
; FPINT IS AN INTERFACE PROGRAM BETWEEN THE
; INTERPRETER AND THE FLOATING POINT PACKAGE
; THE FLOATING POINT PACKAGE IS LOCATED AT
;
; THERE ARE SIX ENTRY POINTS INTO FPINT:
;
; (1) FLTINP - CONVERTS ASCII NUMERIC
; STRING TO FLOATING POINT
;
; (2) FLTOUT - CONVERTS FLOATING POINT
; NUMBER TO AN ASCII STRING
;
; (3) CBIN - CONVERTS FLOATING POINT
; NUMBER TO A BINARY NUMBER
;
; (4) CFLT - CONVERST BINARY NUMBER
; TO A FLOATING POINT NUMBER
;
; (5) FLTRET - PERFORMS FP ARITHMETIC
; OPERATION AND STORES RESULT BACK INTO
; AREA SPECIFIED BY THE INTERPRETER
;
; (6) FLTOP - PERFORMS FP ARITHMETIC
; OPERATION BUT DOES NOT STORE RESULT
; BACK INTO INTERPRETER
;
;
;
;
; ENTRY POINT FOR INP CALL (FUNCTION)
; REG C CONTAINS NUMBER OF CHARACTERS TO CONVERT
; REG D,E POINT TO CHAR STRING TO BE CONVERTED
; TO FLOATING POINT REPRESENTATION. FIRST IT IS
; MOVED TO ACCUM AND THEN CONVERTED. THIS IS DONE
; BECAUSE FP PKG REQUIRES ALL ADDRESSES BE ON ONE PAGE
;
FLTINP:
MOV A,C
ORA A
JNZ FLTI1
MVI C,8
JMP FLTOP
FLTI1: LXI H,ACCUM ;POINTER TO ACCUM
INP1: LDAX D ;LOAD A CHAR
SUI 30H ;CONVERT TO INTERFACE CODE
MOV M,A ;STORE CHAR INTO ACCUM
INX D ;POINT TO NEXT CHAR
INX H ;POINT TO NEXT ACCUM LOC
DCR C ;DECREMENT COUNTER
JNZ INP1 ;LOOP
MVI A,011H ;END OF STRING INDICATOR
MOV M,A
LXI H,ACCUM ;THIS IS WHERE STRING IS NOW
CALL FINP ;CALL FP PKG
RET ;RETURN TO INTERP
;
; ENTRY POINT FOR OUT CALL (FUNCTION 12)
; CONVERT NUMBER IN FP ACCUM TO STRING AND PLACE IT
; IN THE ADDRESS IN REG B,C. ACCUM USED AS INTERM.
; STORAGE OF STRING.
;
FPOUT:
FLTOUT:
PUSH B
LXI H,ACCUM ;TEMP STORE STRING HERE
CALL FOUT ;CONVERT TO ASCII
LXI D,ACCUM+9 ;IS IT IN EXP FORM?
LDAX D ;IF SO THIS IS LETTER E
LXI D,ACCUM+13 ;SETUP REG D,E
CPI 'E' - 30H ;IS IT AN E?
JZ FP2 ;YES LEAVE STRING AS IS
FP1:
; OTHERWISE REMOVE TRAILING BLANKS, ZEROS
DCX D ;NEXT LOCATION
LDAX D ;GET CHAR
CPI 0 ;A ZERO?
JZ FP1 ;YES, SKIP IT
CPI 0F0H ;A BLANK?
JZ FP1 ;YES, SKIP IT
; FOUND NON BLANK, NON ZERO CHAR
CPI 0FEH ;IS IT TRAILING .
JNZ FP3 ;IF SO ELIM
FP2:
DCX D ;IT WAS . SO ELIM
FP3:
POP H ;ADDRESS TO STORE STRING
MOV B,E ;SAVE RIGHT END OF STRING
LXI D,ACCUM ;BEGINNING
FP4:
LDAX D ;GET CHAR
ADI 30H ;CONV TO ASCII
CPI ' ' ;IF A BLANK DO NOT PASS
JZ FP5 ;TO MAIN PROGRAM IE SKIP IT
MOV M,A ;NOT BLANK MOVE IT
INX H ;NEXT LOCATION
FP5:
MOV A,E ;CURRENT POS
INX D ;SETUP FOR NEXT CHAR
CMP B ;COMPLETE?
JNZ FP4 ;NO - CONTINUE
MVI M,' ' ;LEAVE TRAILING BLANK
RET
;
; ENTRY POINT FOR CONVERSION FROM F/P TO BINARY
; REG B,C CONTAINS ADDRESS OF F/P NUMBER
; BINARY NUMBER IS MOVED BACK TO REPLACE F/P NUMBER
;
CBIN: PUSH B ;SAVE ADDRESS
POP D ;NOW ADDRESS IN D,E
PUSH D ;SAVE AGAIN
MVI C,2 ;LOAD FUNCTION NUMBER
CALL FLTOP ;GET F/P NUMBER INTO REG A-D
MVI E,32 ;SET SCALING FACTOR
CALL FFIX ;CALL CONV ROUTINE
JMP EMPTY ;MOVE BACK AND RETURN
;
; ENTRY POINT FOR CONVERSION FROM BINARY TO F/P
; REG B,C CONTAIN ADDRESS OF NUMBER TO CONV
;
CFLT: PUSH B
POP H ;NOW ADDR IN H,L
PUSH H ;ALSO SAVE IT
CALL FETCH ;GET NUMBER TO REG A - D
MVI E,32
CALL FFLOAT ;CALL CONV TO BINARY ROUTINE
JMP EMPTY ;MOVE BACK AND RET
;
; BUILD JUMP TABLE FOR USE BY STORE AND ENTER
;
JUMPT:
DW INITP ;FUNC = 0 INITIALIZE
DW FSTOR ;FUNC = 1 STORE ACCUM
DW FLOAD ;FUNC = 2 LOAD ACCUM
DW FADD ;FUNC = 3 ADD TO ACCUM
DW FSUB ;FUNC = 4 SUB FROM ACCUM
DW FMUL ;FUNC = 5 MULT ACCUM
DW FDIV ;FUNC = 6 DIV ACCUM
DW FABS ;FUNC = 7 ABSOLUTE VALUE
DW FZERO ;FUNC = 8 ZERO ACCUM
DW FTEST ;FUNC = 9 TEST FOR ZERO
DW FCHS ;FUNC = 10 COMPLEMENT ACCUM
DW FSQRT ;FUNC = 11 SQUARE ROOT
DW FCOS ;FUNC = 12 COSINE
DW FSIN ;FUNC = 13 SINE
DW FATAN ;FUNC = 14 ARCTAN
DW FCOSH ;FUNC = 15 COSH
DW FSINH ;FUNC = 16
DW FEXP ;FUNC = 17
DW FLOG ;FUNC = 18
;
; ENTRY POINT WHEN RESULT IE FP ACCUM IS STORED
; BACK INTO ADDRESS PASSED IN D,E.
; REG C IS A FUNCTION
; REG D,E IS ADDRESS OF PARAMETER
;
FLTRET: ;PERFORM OPERATION AND RETURN RESULT
PUSH D ;SAVE RETURN PARAMETER ADDRESS
CALL FLTOP ;RETURNS TO THIS ADDRESS
EMPTY: POP H ;RETURN PARAMETER ADDRESS
MOV M,A
INX H
MOV M,B
INX H
MOV M,C
INX H
MOV M,D
RET
;
;
; ENTRY POINT WHEN NO STORE BACK IS DESIRED
; REG C IS FUNCTION
; REG D,E IS A PARAMETER
;
; GET PROPER FUNCTION BY ADDIING FUNCTION NUMBER IN B
; REGISTER TO THE FIRST FUNCTION ADDRESS SETUP AS A DW
;
FLTOP:
LXI H,JUMPT
MVI B,0
DAD B
DAD B
;
MOV C,M
INX H
MOV B,M
LXI H,JMPIN+1 ;CHANGE ADDRESS FIELD
MOV M,C
INX H
MOV M,B
; JMP INSTRUCTION CHANGED (CANNOT USE PCHL BECAUSE OF H,L PARAMETER)
XCHG ;PARM TO H,L READY FOR CALL
JMPIN: JMP 0000 ;ADDRESS FIELD ALTERED ABOVE
;
;
INITP: XRA A
STA OVER
RET
;
;
INPUT: ;PORT NUMBER, RETURN VALUE IN A
LXI H,INP+1
MOV M,C ;IN XX CHANGED
INP: IN 00 ;CHANGED ABOVE
RET
;
OUTPUT: ;PORT NUMBER, VALUE
LXI H,OUTP+1
MOV M,C ;OUT INSTRUCTION CHANGED
MOV A,E ;VALUE TO SEND
OUTP: OUT 00 ;CHANGED ABOVE
RET
;
RANDOM: JMP RAND
;
; THE FOLLOWING SUBROUTINE MOVES A FOUR BYTE
; QUANTITY FROM MEMORY TO REG A - D
;
FETCH:
MOV A,M
INX H
MOV B,M
INX H
MOV C,M
INX H
MOV D,M
RET
;
END

648
ASSEMBLY & COMPILE TOOLS/Basic-E/source/FPPKG.SRC Normal file
View File

@@ -0,0 +1,648 @@
NAME FLPT
CSEG
PUBLIC OVERF,FLOAD,FSTOR,FADD,FSUB,FMUL,FDIV,FTEST
PUBLIC FCHS,FABS,RSH,LSH,ADD10,FZERO,FCOMP,FSTR0
EXTRN OVER,PREX,ACCE,ACCS,ACC1,ACC2,ACC3,SF
; 8008 BINARY FLOATING POINT SYSTEM
; ARITHMETIC AND UTILITY PACKAGE
; PROGRAMMER CAL OHME
; DATE 26 DECEMBER 1973
; FSTOR SUBROUTINE ENTRY POINT.
FSTR0: MOV M,E; STORE ZEROETH WORD
INR L; TO ADDRESS FIRST WORD
FSTOR: MOV M,A; STORE FIRST WORD
STR1: INR L; TO ADDRESS SECOND WORD
MOV M,B; STORE SECOND WORD
INR L; TO ADDRESS THIRD WORD
MOV M,C; STORE THIRD WORD
INR L; TO ADDRESS FOURTH WORD
MOV M,D; STORE FOURTH WORD
RET ; RETURN TO CALLER
; FLOATING POINT ZERO SUBROUTINE ENT. PNT.
FZERO: LXI H,ACCE; TO ADDRESS ACCUM EXPONENT
XRA A; ZERO
MOV M,A; CLEAR ACCUMULATOR EXPONENT
RET ; RETURN TO CALLER
; FLOATING POINT CHS SUBROUTINE ENT. PNT.
FCHS: MVI A,80H; MASK FOR SIGN BIT
DB 00EH; LBI INST TO SKIP NEXT WD
; FLOATING POINT ABS SUBROUTINE ENT. PNT.
FABS: XRA A; ZERO
LXI H,ACCS; TO ADDRESS ACCUM SIGN
ANA M ; COMPLEMENT OF SIGN
XRI 80H; COMPLEMENT THE SIGN BIT
MOV M,A; ACCUMULATOR SIGN
; FLOATING POINT TEST ENTRY POINT.
FTEST: LXI H,ACCE; TO ADDR ACCUM EXPONENT
MOV A,M; ACCUMULATOR EXPONENT
ANA A ; SET CONTROL BITS
JZ FZERO; IF ACCUMULATOR IS ZERO
MOV E,A; ACCUMULATOR EXPONENT
INR L; TO ADDR ACCUMULATOR SIGN
MOV A,M; ACCUMULATOR SIGN
INR L; TO ADDR ACCUM 1ST FRCTN
XRA M; ACCUM SIGN AND 1ST FRCTN
INR L; TO ADDR ACCUM 2ND FRCTN
MOV C,M; ACCUMULATOR 2ND FRACTION
INR L; TO ADDR ACCUM 3RD FRCTN
MOV D,M; ACCUMULATOR 3RD FRCTN
JMP ADD12; TO SET EXIT CONDITIONS
; FLOATING POINT LOAD ENTRY POINT.
FLOAD: MOV A,M; OPERAND EXPONENT
ANA A ; SET CONTROL BITS
JZ FZERO; IF OPERAND IS ZERO
MOV E,A; OPERAND EXPONENT
INR L; TO ADDR OP SIGN AND 1ST
MOV A,M; OPERAND SIGN AND 1ST FRCTN
INR L; TO ADDRESS OPERAND 2ND FRACTION
MOV C,M; OPERAND 2ND FRACTION
INR L; TO ADDRESS OPERAND 3RD FRACTION
MOV D,M; OPERAND 3RD FRACTION
; STORE THE OPERAND IN THE ACCUMULATOR.
MOV L,A; OPERAND SIGN AND 1ST FRCTN
FLOAD1: ORI 80H; ACCUMULATOR 1ST FRACTION
MOV B,A; ACCUMULATOR 1ST FRACTION
XRA L; ACCUMULATOR SIGN
LXI H,ACCE; TO ADDR ACCUM EXPONENT
CALL FSTR0; SET THE ACCUMULATOR
XRA B; ACCUM SIGN AND 1ST FRCTN
; SET CONTROL BITS AND EXIT
MOV B,A; ACCUM SIGN AND 1ST FRACTION
ORI 1; SET SIGN BIT FOR EXIT
MOV A,E; ACCUMULATOR EXPONENT
RET ; RETURN TO CALLER
; FLOATING POINT MUL SUBROUTINE ENT. PNT.
FMUL: MOV A,M; OPERAND EXPONENT
ANA A ; SET CONTROL BITS
CNZ MDEX; READ OPERAND IF NOT ZERO
JZ FZERO; IF ZERO OR UNDERFLOW
JC OVERF; IF OVERFLOW
CALL MULX; CALL FIXED MULT SUBRTN
; NORMALIZE IF NECESSARY.
MOV A,B; 1ST PRODUCT
ANA A ; SET CONTROL BITS
JM RNDA; IF NO NORMALIZATION REQUIRED
LXI H,ACCE; TO ADDR ACCUM EXPONENT
MOV A,M; ACCUMULATOR EXPONENT
SBI 1; DECREMENT ACCUMULATOR EXPONENT
MOV M,A; ACCUMULATOR EXPONENT
RZ ; RETURN TO CALLER IF UNDERFLOW
CALL LSH; CALL LEFT SHIFT SUBROUTINE
; ROUND IF NECESSARY.
RNDA: CALL ROND; CALL ROUNDING SUBROUTINE
JC OVERF; IF OVERFLOW
MOV B,A; ACCUM SIGN AND 1ST FRACTION
ORI 1; SET SIGN BIT
MOV A,E; ACCUMULATOR EXPONENT
RET ; RETURN TO CALLER
; FLOATING POINT DIV SUBROUTINE ENT. PNT.
FDIV: XRA A; ZERO
SUB M; COMPLEMENT OF DIVISOR EXPONENT
CPI 1; SET CARRY IF DIVISION BY ZERO
CNC MDEX; READ OPERAND IF NOT ZERO
JC OVERF; IF OVERFLOW OR DIVISION BY ZERO
JZ FZERO; IF UNDERFLOW OR ZERO
MOV C,A; DIVISOR 1ST FRACTION
CALL DIVX; CALL FIXED DIV SUBRTN
JC RNDA; IF NO OVERFLOW
; SET OVERFLOW FLAG.
OVERF: LXI H,OVER; TO ADDR OVERFLOW FLAG
MVI A,0FFH; OVERFLOW FLAG
MOV M,A; OVERFLOW FLAG
RLC ; SET CARRY BIT FOR EXIT
RET ; RETURN TO CALLER
DB 0; CHECK SUM WORD
; FLOATING POINT SUB SUBROUTINE ENT. PNT.
FSUB: MVI A,80H; MASK TO CHANGE OP SIGN
DB 0EH; LBI INST TO SKIP NEXT WD
; FLOATING POINT ADD SUBROUTINE ENT. PNT.
FADD: XRA A; ZERO
; LOAD THE OPERAND.
MOV E,M; OPERAND EXPONENT
INR L; TO ADDR OP SIGN, 1ST FRCTN
XRA M; OPERAND SIGN AND 1ST FRCTN
MOV B,A; OPERAND SIGN AND 1ST FRCTN
INR L; TO ADDR OPERAND 2ND
MOV C,M; OPERAND 2ND FRACTION
INR L; TO ADDR OPERAND 3RD FRCTN
MOV D,M; OPERAND 3RD FRACTION
; SAVE INITIAL EXPONENT.
LXI H,ACCE; TO ADDR ACCUM EXPONENT
MOV A,M; ACCUMULATOR EXPONENT
DCR L; TO ADDR INITIAL EXPONENT
MOV M,A; INITIAL EXPONENT
; CHECK FOR ZERO OPERAND.
MOV A,E; OPERAND EXPONENT
ANA A ; SET CONTROL BITS
JZ FTEST; IF OPERAND IS ZERO
; GENERATE SUBTRACTION FLAG, RESTORE
; SUPPRESSED FRACTION BIT.
MOV L,B; OPERAND SIGN AND 1ST FRCTN
MOV A,B; OPERAND SIGN AND 1ST FRACTION
ORI 80H; OPERAND 1ST FRACTION
MOV B,A; OPERAND 1ST FRACTION
XRA L; OPERAND SIGN
MVI L,LOW(ACCS); TO ADDRESS ACCUMULATOR SIGN
XRA M; SUBTRACTION FLAG
MVI L,LOW(SF); TO ADDRESS SUBTRACTION FLAG
MOV M,A; SUBTRACTION FLAG
; DETERMINE RELATIVE MAGNITUDES OF
; OPERAND AND ACCUMULATOR.
MVI L,LOW(ACCE); TO ADDRESS ACCUMULATOR EXPONENT
MOV A,M; ACCUMULATOR EXPONENT
ANA A ; SET CONTROL BITS
JZ ADD17; IF ACCUMULATOR IS ZERO
SUB E; DIFFERENCE IN EXPONENTS
JC ADD2; IF ACCUM SMALLER THAN OP
; CHECK FOR INSIGNIFICANT OPERAND.
JM FTEST; IF THE OPERAND IS INSIGNIFICANT
CPI 25; COMPARE SHIFT COUNT TO 25
JC ADD3; JOIN EXCH PATH IF OP SIGNIF
JMP FTEST; OPERAND IS INSIGNIFICANT
; CHECK FOR INSIGNIFICANT ACCUMULATOR
ADD2: JP ADD17; IF ACCUM IS INSIGNIFICANT
CPI 0E7H; COMPARE SHIFT COUNT TO MINUS 25
JC ADD17; IF ACCUM IS INSIGNIFICANT
MOV M,E; OPERAND EXPONENT
MOV E,A; SHIFT COUNT
LXI H,SF; TO ADDRESS THE SUBTRACTION FLAG
MOV A,M; SUBTRACTION FLAG
MVI L,LOW(ACCS); TO ADDRESS THE ACCUMULATOR SIGN
XRA M; OPERAND SIGN
MOV M,A; ACCUMULATOR SIGN
XRA A; ZERO
SUB E; COMPLEMENT SHIFT COUNT
; EXCHANGE ACCUMULATOR AND OPERAND.
INR L; TO ADDR ACCUM 1ST FRACTION
MOV E,M; ACCUMULATOR 1ST FRACTION
MOV M,B; OPERAND 1ST FRACTION
MOV B,E; ACCUMULATOR 1ST FRACTION
INR L; TO ADDR ACCUM 2ND FRACTION
MOV E,M; ACCUMULATOR 2ND FRACTION
MOV M,C; OPERAND 2ND FRACTION
MOV C,E; ACCUMULATOR 2ND FRACTION
INR L; TO ADDR ACCUM 3RD FRACTION
MOV E,M; ACCUMULATOR 3RD FRACTION
MOV M,D; OPERAND 3RD FRACTION
MOV D,E; ACCUMULATOR 3RD FRACTION
; POSITION THE OPERAND.
ADD3: CALL RSH; POSITION THE OPERAND
LXI H,SF; TO ADDRESS SUBTRACTION FLAG
MOV A,M; SUBTRACTION FLAG
ANA A ; SET CONTROL BITS
MVI L,LOW(ACC3); TO ADDR ACCUM 3RD FRCTN
JM ADD9; IF SUBTRACTION REQUIRED
; ADD ADDEND TO AUGEND.
MOV A,M; AUGEND 3RD FRACTION
ADD D; ADDEND 3RD FRACTION
MOV D,A; SUM 3RD FRACTION
DCR L; TO ADDRESS AUGEND 2ND FRACTION
MOV A,M; AUGEND 2ND FRACTION
ADC C; ADDEND 2ND FRACTION
MOV C,A; SUM 2ND FRACTION
DCR L; TO ADDRESS AUGEND 1ST FRACTION
MOV A,M; AUGEND 1ST FRACTION
ADC B; ADDEND 1ST FRACTION
MOV B,A; SUM 1ST FRACTION
JNC ADD11; IF NO CARRY FROM 1ST FRCTN
; RIGHT SHIFT SUM TO NORMALIZED POSITION.
RAR ; RIGHT SHIFT SUM 1ST FRACTION
MOV B,A; SUM 1ST FRACTION
MOV A,C; SUM 2ND FRACTION
RAR ; RIGHT SHIFT SUM 2ND FRACTION
MOV C,A; SUM 2ND FRACTION
MOV A,D; SUM 3RD FRACTION
RAR ; RIGHT SHIFT SUM 3RD FRACTION
MOV D,A; SUM 3RD FRACTION
RAR ; 4TH FRCTN = LOW BIT OF 3RD
MOV E,A; SUM 4TH FRACTION
MVI L,LOW(ACCE); TO ADDRESS ACCUMULATOR EXPONENT
MOV A,M; ACCUMULATOR EXPONENT
ADI 1; INCREMENT ACCUMULATOR EXPONENT
JC OVERF; IF OVERFLOW
MOV M,A; ACCUMULATOR EXPONENT
JMP ADD11; TO ROUND FRACTION
; SUBTRACT SUBTRAHEND FROM MINUEND.
ADD9: XRA A; MINUEND 4TH FRCTN IS ZERO
SUB E; SUBTRAHEND 4TH FRACTION
MOV E,A; DIFFERENCE 4TH FRACTION
MOV A,M; MINUEND 3RD FRACTION
SBB D; SUBTRAHEND 3RD FRACTION
MOV D,A; DIFFERENCE 3RD FRACTION
DCR L; TO ADDRESS MINUEND 2ND FRACTION
MOV A,M; MINUEND 2ND FRACTION
SBB C; SUBTRAHEND 2ND FRACTION
MOV C,A; DIFFERENCE 2ND FRACTION
DCR L; TO ADDRESS MINUEND 1ST FRACTION
MOV A,M; MINUEND 1ST FRACTION
SBB B; SUBTRAHEND 1ST FRACTION
MOV B,A; DIFFERENCE 1ST FRACTION
ADD10: CC FCOMP; COMPLEMENT IF NEGATIVE
CP NORM; NORMALIZE IF NECESSARY
JP FZERO; IF UNDERFLOW OR ZERO
ADD11: CALL ROND; CALL ROUNDING SUBROUTINE
JC OVERF; IF OVERFLOW
ADD12: MOV B,A; ACCUM SIGN AND 1ST FRCTN
LXI H,PREX; TO ADDRESS PREV EXPONENT
MOV A,E; ACCUMULATOR EXPONENT
SUB M; DIFFERENCE IN EXPONENTS
MOV L,A; DIFFERENCE IN EXPONENTS
MOV A,B; ACCUM SIGN AND 1ST FRCTN
ORI 1; SET SIGN BIT FOR EXIT
MOV A,E; ACCUMULATOR EXPONENT
MOV E,L; SIGNIFICANCE INDEX
RET ; RETURN TO CALLER
; LOAD THE ACCUMULATOR WITH THE OPERAND.
ADD17: LXI H,SF; TO ADDR SUBTRACTION FLAG
MOV A,M; SUBTRACTION FLAG
MVI L,LOW(ACCS); TO ADDR ACCUMULATOR SIGN
XRA M; OPERAND SIGN
DCR L; TO ADDR ACCUM EXPONENT
CALL FSTR0; SET THE ACCUMULATOR
XRA B; ACCUM SIGN AND 1ST FRCTN
JMP ADD12; JOIN EXIT CODE
DB 0; CHECK SUM WORD
; SUBROUTINE TO READ THE OPERAND AND
; CHECK THE ACCUMULATOR EXPONENT.
MDEX: MOV B,A; EXPONENT MODIFIER
INR L; TO ADDR OP SIGN, 1ST FRCTN
MOV C,M; OPERAND SIGN AND 1ST FRACTION
INR L; TO ADDRESS OPERAND 2ND FRACTION
MOV D,M; OPERAND 2ND FRACTION
INR L; TO ADDRESS OPERAND 3RD FRACTION
MOV E,M; OPERAND 3RD FRACTION
LXI H,ACCE; TO ADDRESS ACCUMULATOR EXPONENT
MOV A,M; ACCUMULATOR EXPONENT
ANA A ; SET CONTROL BITS
RZ ; RETURN IF ACCUM IS ZERO
ADD B; RESULT EXPONENT PLUS BIAS
MOV B,A; RESULT EXPONENT PLUS BIAS
RAR ; CARRY TO SIGN
XRA B; CARRY AND SIGN MUST DIFFER
MOV A,B; RESULT EXPONENT PLUS BIAS
MVI B,80H; EXP BIAS, SIGN MASK, MS BIT
JP OVUN; IF OVERFLOW OR UNDERFLOW
SUB B; REMOVE EXCESS EXP BIAS
RZ ; RETURN IF UNDERFLOW
MOV M,A; RESULT EXPONENT
INR L; TO ADDRESS ACCUMULATOR SIGN
MOV A,M; ACCUMULATOR SIGN
XRA C; RESULT SIGN IN SIGN BIT
ANA B ; RESULT SIGN
MOV M,A; RESULT SIGN
MOV A,C; OPERAND SIGN AND 1ST FRCTN
ORA B; OPERAND 1ST FRACTION
RET ; RETURN TO CALLER
OVUN: RLC ; SET CARRY BIT IF OVERFLOW
RC ; RETURN IF OVERFLOW
XRA A; ZERO
RET ; RETURN IF UNDERFLOW
; SUBROUTINE TO LEFT SHIFT THE B, C,
; D, AND E REGISTERS ONE BIT.
LSH: MOV A,E; ORIGINAL CONTENTS OF E
RAL ; LEFT SHIFT E
MOV E,A; RESTORE CONTENTS OF E REGISTER
LSH1: MOV A,D; ORIGINAL CONTENTS OF D REGISTER
RAL ; LEFT SHIFT D
MOV D,A; RESTORE CONTENTS OF D REGISTER
MOV A,C; ORIGINAL CONTENTS OF C REGISTER
RAL ; LEFT SHIFT C
MOV C,A; RESTORE CONTENTS OF C REGISTER
MOV A,B; ORIGINAL CONTENTS OF B REGISTER
ADC A; LEFT SHIFT B
MOV B,A; RESTORE CONTENTS OF B REGISTER
RET ; RETURN TO CALLER
; RIGHT SHIFT THE B, C, D AND E REGISTERS
; BY THE SHIFT COUNT IN THE A REGISTER
; SHIFT OPERAND TO REGISTER INDICATED BY
; SHIFT COUNT
RSH: MVI E,0; OPERAND 4TH FRCTN IS ZERO
RSH0: MVI L,8; EACH REG IS 8 BITS OF SHIFT
RSH1: CMP L; COMPARE SHIFT COUNT TO 8
JM RSH2; IF REQ SHIFT LESS THAN 8
MOV E,D; OPERAND 4TH FRACTION
MOV D,C; OPERAND 3RD FRACTION
MOV C,B; OPERAND 2ND FRACTION
MVI B,0; OPERAND 1ST FRACTION IS ZERO
SUB L; REDUCE SHIFT COUNT BY 1 REG
JNZ RSH1; IF MORE SHIFTS REQUIRED
; SHIFT OPERAND RIGHT BY -SHIFT COUNT-
; BITS.
RSH2: ANA A ; SET CONTROL BITS
RZ ; RETURN IF SHIFT COMPLETE
MOV L,A; SHIFT COUNT
RSH3: ANA A ; CLEAR CARRY BIT
MOV A,B; OPERAND 1ST FRACTION
RAR ; RIGHT SHIFT OP 1ST FRCTN
MOV B,A; OPERAND 1ST FRACTION
MOV A,C; OPERAND 2ND FRACTION
RAR ; RIGHT SHIFT OP 2ND FRCTN
MOV C,A; OPERAND 2ND FRACTION
MOV A,D; OPERAND 3RD FRACTION
RAR ; RIGHT SHIFT OP 3RD FRCTN
MOV D,A; OPERAND 3RD FRACTION
MOV A,E; OPERAND 4TH FRACTION
RAR ; RIGHT SHIFT OP 4TH FRCTN
MOV E,A; OPERAND 4TH FRACTION
DCR L; DECREMENT SHIFT COUNT
JNZ RSH3; IF MORE SHIFTS REQUIRED
RET ; RETURN TO CALLER
; COMPLEMENT THE B, C, D, AND E REGISTERS.
FCOMP: DCR L; TO ADDR ACCUM SIGN
MOV A,M; ACCUMULATOR SIGN
XRI 80H; CHANGE SIGN
MOV M,A; ACCUMULATOR SIGN
COMP1: XRA A; ZERO
MOV L,A; ZERO
SUB E; COMPLEMENT 4TH FRCTN
MOV E,A; 4TH FRACTION
MOV A,L; ZERO
SBB D; COMPLEMENT 3RD FRCTN
MOV D,A; 3RD FRACTION
MOV A,L; ZERO
SBB C; COMPLEMENT 2ND FRCTN
MOV C,A; 2ND FRACTION
MOV A,L; ZERO
SBB B; COMPLEMENT 1ST FRCTN
MOV B,A; 1ST FRACTION
RET ; RETURN TO CALLER
; NORMALIZE THE REGISTERS.
NORM: MVI L,20H; MAX NORMALIZING SHIFT
NORM1: MOV A,B; 1ST FRACTION
ANA A ; SET CONTROL BITS
JNZ NORM3; IF 1ST FRACTION NONZERO
MOV B,C; 1ST FRACTION
MOV C,D; 2ND FRACTION
MOV D,E; 3RD FRACTION
MOV E,A; ZERO 4TH FRACTION
MOV A,L; NORMALIZING SHIFT COUNT
SUI 8; REDUCE SHIFT COUNT
MOV L,A; NORMALIZING SHIFT COUNT
JNZ NORM1; IF FRACTION NONZERO
RET ; IF FRACTION IS ZERO
NORM2: DCR L; DECREMENT SHIFT COUNT
MOV A,E; ORIGINAL CONTENTS OF E
RAL ; LEFT SHIFT E
MOV E,A; RESTORE CONTENTS OF E REGISTER
MOV A,D; ORIGINAL CONTENTS OF D REGISTER
RAL ; LEFT SHIFT D
MOV D,A; RESTORE CONTENTS OF D REGISTER
MOV A,C; ORIGINAL CONTENTS OF C REGISTER
RAL ; LEFT SHIFT C
MOV C,A; RESTORE CONTENTS OF C REGISTER
MOV A,B; ORIGINAL CONTENTS OF B REGISTER
ADC A; LEFT SHIFT B
MOV B,A; RESTORE CONTENTS OF B REGISTER
NORM3: JP NORM2; IF NOT NORMALIZED
MOV A,L; NORMALIZING SHIFT COUNT
SUI 20H; REMOVE BIAS
LXI H,ACCE; TO ADDR ACCUM EXPONENT
ADD M; ADJUST ACCUM EXPONENT
MOV M,A; NEW ACCUM EXPONENT
RZ ; RETURN IF ZERO EXP
RAR ; BORROW BIT TO SIGN
ANA A ; SET SIGN TO IND. UNDERFLOW
RET ; RETURN TO CALLER
; SUBROUTINE TO ROUND THE B, C, D REGISTERS.
ROND: LXI H,ACCE; TO ADDR ACCUM EXPONENT
MOV A,E; 4TH FRACTION
ANA A ; SET CONTROL BITS
MOV E,M; ACCUMULATOR EXPONENT
CM RNDR; CALL 2ND LEVEL ROUNDER
RC ; IF OVERFLOW
MOV A,B; 1ST FRACTION
INR L; TO ADDR ACCUM SIGN
XRA M; ACCUM SIGN AND 1ST FRCTN
JMP STR1; RETURN THRU STORE SUBR.
; SECOND LEVEL ROUNDING SUBROUTINE.
RNDR: INR D; ROUND 3RD FRACTION
RNZ ; RETURN IF NO CARRY
INR C; CARRY TO 2ND FRACTION
RNZ ; RETURN IF NO CARRY
INR B; CARRY TO 1ST FRACTION
RNZ ; RETURN IF NO CARRY
MOV A,E; ACCUMULATOR EXPONENT
ADI 1; INCREMENT ACCUM EXPONENT
MOV E,A; NEW ACCUM EXPONENT
MVI B,80H; NEW 1ST FRACTION
MOV M,A; NEW ACCUM EXPONENT
RET ; RETURN TO ROND SUBROUTINE
; FIXED POINT MULTIPLY SUBROUTINE.
MULX: LXI H,MULP1+1; TO ADDR 1ST MULTIPLICAND
MOV M,A; 1ST MULTIPLICAND
LXI H,MULP2+1; TO ADDR 2ND MULTIPLICAND
MOV M,D; 2ND MULTIPLICAND
LXI H,MULP3+1; TO ADDR 3RD MULTIPLICAND
MOV M,E; 3RD MULTIPLICAND
XRA A; CLEAR 6TH PRODUCT
MOV E,A; CLEAR 5TH PRODUCT
MOV D,A; CLEAR 4TH PRODUCT
; MULTIPLY BY EACH ACCUMULATOR
; FRACTION IN TURN.
LXI H,ACC3; TO ADDRESS 3RD FRCTN
CALL MULX2; MULTIPLY BY ACCUM 3RD FRCTN
MVI L,LOW(ACC2); TO ADDRESS 2ND FRCTN
CALL MULX1; MULTIPLY BY ACCUM 2ND FRCTN
MVI L,LOW(ACC1); TO ADDRESS 1ST FRCTN
; MULTIPLY BY ONE ACCUMULATOR WORD.
MULX1: MOV A,D; 5TH PARTIAL PRODUCT
MOV E,C; 4TH PARTIAL PRODUCT
MOV D,B; 3RD PARTIAL PRODUCT
MULX2: MOV B,M; MULTIPLIER
MOV L,A; 5TH PARTIAL PRODUCT
XRA A; ZERO
MOV C,A; 2ND PARTIAL PRODUCT
SUB B; SET CARRY BIT FOR EXIT FLAG
JC MULX3; IF MULTIPLIER IS NOT ZERO
MOV C,D; 2ND PARTIAL PRODUCT
MOV D,E; 3RD PARTIAL PRODUCT
RET ; MULT BY ZERO COMPLETE
; COMPLETE ADDITION OF MULTIPLICAND.
MULX5: MOV C,A; 2ND PARTIAL PRODUCT
JNC MULX3; IF NO CARRY TO 1ST PRODUCT
INR B; ADD CARRY TO 1ST PRODUCT
ANA A ; CLEAR CARRY BIT
; LOOP FOR EACH BIT OF MULTIPLIER WORD.
MULX3: MOV A,L; 5TH PART PRODUCT, EXIT FLAG
ADC A; SHIFT EXIT FLAG OUT IF DONE
RZ ; EXIT IF MULTIPLICATION DONE
MOV L,A; 5TH PART PRODUCT, EXIT FLAG
MOV A,E; 4TH PARTIAL PRODUCT
RAL ; SHIFT 4TH PARTIAL PRODUCT
MOV E,A; 4TH PARTIAL PRODUCT
MOV A,D; 3RD PARTIAL PRODUCT
RAL ; SHIFT 3RD PARTIAL PRODUCT
MOV D,A; 3RD PARTIAL PRODUCT
MOV A,C; 2ND PARTIAL PRODUCT
RAL ; SHIFT 2ND PARTIAL PRODUCT
MOV C,A; 2ND PARTIAL PRODUCT
MOV A,B; 1ST PART PROD AND MULTPLIER
RAL ; SHIFT 1ST PROD AND MULTIPLIER
MOV B,A; 1ST PART PROD AND MULTIPLIER
JNC MULX3; IF NO ADDITION REQUIRED
; ADD THE MULTIPLICAND TO THE PRODUCT
; IF THE MULTIPLIER BIT IS ONE.
MOV A,E; 4TH PARTIAL PRODUCT
; THE FOLLOWING CODE WAS MOVED FROM THE BEGINNING
; OF THE PROGRAM TO THIS LOCATION TO MAKE THINGS
; A LITTLE EASIER...
MULX4:
MULP3:
ADI 0; ADD OPERAND 3RD FRACTION
MOV E,A; 4TH PARTIAL PRODUCT
MOV A,D; 3RD PARTIAL PRODUCT
MULP2:
ACI 0; ADD OPERAND 2ND FRACTION
MOV D,A; 3RD PARTIAL PRODUCT
MOV A,C; 2ND PARTIAL PRODUCT
MULP1:
ACI 0; ADD OPERAND 1ST FRACTION
JMP MULX5
; FIXED POINT DIVIDE SUBROUTINE.
; SUBTRACT DIVISOR FROM ACCUMULATOR TO
; OBTAIN 1ST REMAINDER.
DIVX: LXI H,ACC3; TO ADDRESS ACCUM 3RD FRCTN
MOV A,M; ACCUMULATOR 3RD FRACTION
SUB E; DIVISOR 3RD FRACTION
MOV M,A; REMAINDER 3RD FRACTION
DCR L; TO ADDRESS ACCUM 2ND FRCTN
MOV A,M; ACCUMULATOR 2ND FRACTION
SBB D; DIVISOR 2ND FRACTION
MOV M,A; REMAINDER 2ND FRACTION
DCR L; TO ADDRESS ACCUM 1ST FRCTN
MOV A,M; ACCUMULATOR 1ST FRACTION
SBB C; DIVISOR 1ST FRACTION
MOV M,A; REMAINDER 1ST FRACTION
; HALVE THE DIVISOR AND STORE FOR
; ADDITION OR SUBTRACTION.
MOV A,C; DIVISOR 1ST FRACTION
RAL ; SET CARRY BIT
MOV A,C; DIVISOR 1ST FRACTION
RAR ; HALF OF DIVISOR 1ST FRCTN
; + 80H TO CORRECT QUOTIENT
LXI H,OP1S+1; TO ADDRESS 1ST SUBTRACT DIVISOR
MOV M,A; 1ST SUBTRACT DIVISOR
LXI H,OP1A+1; TO ADDRESS 1ST ADD DIVISOR
MOV M,A; 1ST ADD DIVISOR
MOV A,D; DIVISOR 2ND FRACTION
RAR ; HALF OF DIVISOR 2ND FRACTION
LXI H,OP2S+1; TO ADDRESS 2ND SUBTRACT DIVISOR
MOV M,A; 2ND SUBTRACT DIVISOR
LXI H,OP2A+1; TO ADDRESS 2ND ADD DIVISOR
MOV M,A; 2ND ADD DIVISOR
MOV A,E; DIVISOR 3RD FRACTION
RAR ; HALF OF DIVISOR 3RD FRACTION
LXI H,OP3S+1; TO ADDRESS 3RD SUBTRACT DIVISOR
MOV M,A; 3RD SUBTRACT DIVISOR
LXI H,OP3A+1; TO ADDRESS 3RD ADD DIVISOR
MOV M,A; 3RD ADD DIVISOR
MVI B,0; INIT QUOTIENT 1ST FRCTN
MOV A,B; DIVISOR FOURTH FRACTION IS ZERO
RAR ; LOW BIT OF DIVISOR 3RD FRACTION
LXI H,OP4S+1; TO ADDRESS 4TH SUBTRACT DIVISOR
MOV M,A; 4TH SUBTRACT DIVISOR
LXI H,OP4A+1; TO ADDRESS 4TH ADD DIVISOR
MOV M,A; 4TH ADD DIVISOR
LXI H,OP4X+1; TO ADDRESS 4TH ADD DIVISOR
MOV M,A; 4TH ADD DIVISOR
; LOAD 1ST REMAINDER, CHECK SIGN.
LXI H,ACC1; TO ADDR REMAINDER 1ST FRCTN
MOV A,M; REMAINDER 1ST FRACTION
INR L; TO ADDR REMAINDER 2ND FRCTN
MOV D,M; REMAINDER 2ND FRACTION
INR L; TO ADDR REMAINDER 3RD FRCTN
MOV E,M; REMAINDER 3RD FRACTION
ANA A ; SET CONTROL BITS
JM DIVX4; IF REMAINDER IS NEGATIVE
; ADJUST EXPONENT,POSITION REMAINDER
; AND INITIALIZE THE QUOTIENT.
MVI L,LOW(ACCE); TO ADDRESS ACCUMULATOR EXPONENT
MOV C,M; QUOTIENT EXPONENT
INR C; INCREMENT QUOTIENT EXPONENT
RZ ; RETURN IF OVERFLOW
MOV M,C; QUOTIENT EXPONENT
MOV L,E; REMAINDER 3RD FRACTION
MOV H,D; REMAINDER 2ND FRACTION
MOV E,A; REMAINDER 1ST FRACTION
MVI D,1; INITIALIZE QUOT 3RD FRCTN
MOV C,B; INITIALIZE QUOT 2ND FRCTN
; SUBTRACT THE DIVISOR FROM THE REMAINDER
; IF IT IS POSITIVE
DIVX1: XRA A; REMAINDER 4TH FRCTN IS ZERO
CALL DIVX5;
DIVX2: RLC ; SHFT REM 4TH FRCTN TO CY
; SHIFT THE REMAINDER LEFT ONE BIT.
MOV A,B; QUOTIENT 1ST FRACTION
RAL ; MS BIT OF QUOTIENT TO CY
RC ; IF DIVISION COMPLETE
RAR ; REMAINDER 4TH FRCTN TO CY
MOV A,L; REMAINDER 3RD FRACTION
RAL ; LEFT SHIFT REM 3RD FRCTN
MOV L,A; REMAINDER 3RD FRACTION
MOV A,H; REMAINDER 2ND FRACTION
RAL ; LEFT SHIFT REM 2ND FRCTN
MOV H,A; REMAINDER 2ND FRACTION
CALL LSH; CALL LEFT SHIFT SUBROUTINE
; BRANCH IF SUBTRACTION IS REQUIRED
MOV A,D; QUOTIENT 3RD FRACTION
RRC ; REM SIGN INDIC TO CARRY BIT
JC DIVX1; TO SUB DIVISOR IF REM POS
; ADD THE DIVISOR IF THE REMAINDER
; IS NEGATIVE.
DIVX3: MOV A,L; REMAINDER 3RD FRACTION
JMP DIVX6;
; POSITION THE REMAINDER AND INITIALIZE
; THE QUOTIENT.
DIVX4: MOV L,E; REMAINDER 3RD FRACTION
MOV H,D; REMAINDER 2ND FRACTION
MOV E,A; REMAINDER 1ST FRACTION
MOV D,B; INITIALIZE QUOT 3RD FRCTN
MOV C,B; INITIALIZE QUOT 2ND FRCTN
JMP DIVX3; ADD DIVISOR IF REM IS NEG
; ORIGINALLY, THIS CODE WAS AT THE BEGINNING
; OF THE PROGRAM...
DIVX5:
OP4S:
SUI 0; SUB DIVISOR 4TH FRACTION
MOV A,L; REM 3RD FRACTION
OP3S:
SBI 0; SUB DIVISOR 3RD FRACTION
MOV L,A; REM 3RD FRACTION
MOV A,H; REM 2ND FRACTION
OP2S:
SBI 0; SUB DIVISOR 2ND FRACTION
MOV H,A; REM 2ND FRACTION
MOV A,E; REM 1ST FRACTION
OP1S:
SBI 0; SUB DIVISOR 1ST FRACTION
MOV E,A; REM 1ST FRACTION
OP4A:
MVI A,0; REM 4TH FRACTION
RET
DIVX6:
OP3A:
ADI 0; ADD DIVISOR 3RD FRACTION
MOV L,A; REM 3RD FRACTION
MOV A,H; REM 2ND FRACTION
OP2A:
ACI 0; ADD DIVISOR 2ND FRACTION
MOV H,A; REM 2ND FRACTION
MOV A,E; REM 1ST FRACTION
OP1A:
ACI 0; ADD DIVISOR 1ST FRACTION
MOV E,A; REM 1ST FRACTION
OP4X:
MVI A,0; REM 4TH FRACTION
JMP DIVX2
END

BIN
ASSEMBLY & COMPILE TOOLS/Basic-E/source/RUN.COM Normal file
View File

Binary file not shown.

2292
ASSEMBLY & COMPILE TOOLS/Basic-E/source/RUN.PLM Normal file
View File

File diff suppressed because it is too large Load Diff

577
ASSEMBLY & COMPILE TOOLS/Basic-E/source/TRAN.SRC Normal file
View File

@@ -0,0 +1,577 @@
NAME FPINT
CSEG
;
;
; LINK TO EXTERNAL REFERENCES
;
EXTRN FSTOR,FLOAD,FADD,FTEST,FZERO,FABS,FMUL,FDIV
EXTRN FFLOAT,FFIX,FCHS,FSUB
EXTRN OVER
EXTRN OVERF,ACC2,ACCE
EXTRN SEED
PUBLIC IDV,FCOSH,FSQRT,FSIN,FCOS,FATAN,FSINH,FEXP,FLOG
PUBLIC RAND
;
; ENTRY IDV - INVERSE FDIVIDE
;
; STORAGE IN SCRATCH PAD
SCRT: DS 25
IDVT EQU SCRT + 00H
;
IDV: PUSH H
CALL FTEST ;FLOATING POINT ACCUMULATOR TO REGISTERS
LXI H,IDVT
CALL FSTOR ;FDIVISOR TO STORAGE
POP H
CALL FLOAD ;FDIVIDEND TO FLOATING POINT ACCUMULATOR
LXI H,IDVT
JMP FDIV ;RETURN THROUGH DIV ROUTINE
;
;
;
; FLOATING POINT SQUARE ROOT ROUTINE BY NEWTONIAN ITERATION
;
; THE SQUARE ROOT OF THE FABSOLUTE VALUE OF THE
; CONTENTS OF THE FLOATING POINT ACCUMULATOR IS
; RETURNED IN THE FLOATING POINT ACCUMULATOR.
;
;
; STORAGE IN SCRATCH BANK
FSQRN EQU SCRT + 00H
FSQRX EQU SCRT + 04H
;
FSQRT: CALL FABS ;FORCE ARGUMENT POSITIVE, SET ZERO FLAG
RZ ;RETURN ON ZERO
LXI H,FSQRN
CALL FSTOR
ANA A ;RESET CARRY BIT
RAR ;HALVE THE EXPONENT
ADI 40H ;RESTORE THE OFFSET
LXI H,FSQRX
CALL FSTOR
MVI D,5 ;ITERATION COUNT
PUSH D ;STACKED
FSQRL: LXI H,FSQRN
CALL FLOAD
LXI H,FSQRX
CALL FDIV
LXI H,FSQRX
CALL FADD
SUI 1 ;HALVE THE RESULT
LXI H,FSQRX
CALL FSTOR
POP D ;RESTORE ITERATION COUNT
DCR D ;TALLY
JZ FSQRE ;EXIT WHEN COUNT EXHAUSTED
PUSH D ;SAVE IT OTHERWISE
JMP FSQRL ;TO NEXT ITERATION
FSQRE: LXI H,FSQRX ;RESULT TO ACCUMULATOR
CALL FLOAD
RET
;
; EVALUATION OF ELEMENTARY FUNCTION MACLAURIN SERIES
;
;
; ENTRY FMACE FOR EXPONENTIAL TYPE SERIES, E.G.
; SINH(Z) = Z/1 + Z^3/6 + Z^5/120 + ...
; S(I-1) = (1. + X*S(I)/A(I)), S(N) = 1.
;
; ENTRY FMACL FOR LOGARITHMIC TYPE SERIES, E.G.
; ARCTAN(Z) = Z/1 - Z^3/3 + Z^5/5 - ...
; S(I-1) = (1./A(I) + X*S(I)), S(N) = 0.
;
; IN BOTH SERIES DEL^2(A(I)) MUST BE CONSTANT.
; ENTER WITH X IN FMACX, A(N) IN D, D(A(N-1)) IN C,
; D^2(A(1)) IN B.
; RESULT IN FMACS, WHEN A(I) <= 0.
;
; STORAGE IN SCRATCH BANK
FMACX EQU SCRT+00H
FMACS EQU SCRT+04H
FMACT EQU SCRT+08H
FMACG EQU SCRT+0CH
;
; TWO SUBROUTINE LEVELS USED
;
FMACL: XRA A ;CLEAR A REGISTER FOR LOG TYPE SERIES
LXI H,FMACS ;POINT TO SIGMA
MOV M,A ;ZERO STORED
LXI H,FMACB ;PRESET BRANCH B
JMP FMACC ;JOINT CODE
FMACE: LHLD FONE ;MOVE 1.0 TO SIGMA FOR EXP TYPE SERIES
SHLD FMACS
LHLD FONE+2
SHLD FMACS+2
LXI H,FMACA ;PRESET BRANCH A
FMACC: SHLD FMACG ;STORE PRESET BRANCH
MVI E,32 ;COUNT FOR THE FLOATING OF A(I)
FMACD: PUSH B ;CHAIN RULE LOOP
PUSH D ;SAVE A(I), D(A(I)), D^2(A(1))
XRA A ;ZERO THE LEAD POSITIONS OF A(I)
MOV B,A
MOV C,A
CALL FFLOAT ;FLOAT A(I)
LXI H,FMACT
CALL FSTOR
LXI H,FMACX
CALL FLOAD
LXI H,FMACS
CALL FMUL
LHLD FMACG ;CHOOSE THE BRANCH
PCHL
FMACA: LXI H,FMACT
CALL FDIV
LXI H,FONE ;POINTS TO 1.0
JMP FMACF ;REJOIN COMMON CODE
FMACB: LXI H,FMACS
CALL FSTOR ;X*SIGMA
LXI H,FONE ;LOAD 1.0
CALL FLOAD
LXI H,FMACT
CALL FDIV ;1/A(I)
LXI H,FMACS
FMACF: CALL FADD
LXI H,FMACS
CALL FSTOR
POP D ;A(I) AND 32
POP B ;D(A) AND D^2(A)
MOV A,D
SUB C
RZ ;DONE IF ZERO
RC ;OR NEGATIVE
MOV D,A ;A(I-1)
MOV A,C ;D(A(I-1))
SUB B
MOV C,A ;D(A(I-2))
JMP FMACD ;NEXT ITERATION
FONE: DB 81H,0,0,0 ;CAN BE IN ROM
FPIV2: DB 81H,49H,0FH,0DCH;PI/2
FLN2: DB 80H,31H,72H,18H;LN 2
;
;
; SINE-COSINE ROUTINE USING MACLAURIN SERIES
;
;
; ENTRY FSIN FOR SIN(X)
; ENTRY FCOS FOR COS(X)
; ENTER WITH X IN RADIANS IN FLOATING POINT ACCUMULATOR
; RETURNS WITH FUNCTION IN FLOATIG POINT ACCUMULATOR
; (IF FABS(X) >= 2^24*PI, OVERFLOW FLAG IS SET)
;
; STORAGE IN SCRATCH BANK
FSINX EQU SCRT+10H
;
; THREE LEVELS OF SUBROUTINES USED
;
FCOS: CALL FCHS ;COMPLEMENT THE ANGLE
LXI H,FPIV2
CALL FADD
FSIN: CALL FTEST ;FETCH ARGUMENT
LXI H,FSINX
CALL FSTOR
LXI H,FPIV2 ;REDUCE X TO REVOLUTIONS*4
CALL FDIV
MVI E,26 ;REVOLUTIONS AT BINARY SCALE 24
CALL FFIX
JC OVERF ;QUIT IF ANGLE TO LARGE
MVI E,26
MVI D,0 ;WIPE OUT FRACTIONAL REVOLUTIONS
CALL FFLOAT ;INTEGER PART OF REVOLUTIONS
LXI H,FPIV2 ;TO RADIANS
CALL FMUL
CALL FCHS
FSINA: LXI H,FSINX
CALL FADD
LXI H,FSINX
CALL FSTOR
CALL FABS ;FORCE ANGLE INTO REDUCED RANGE
LXI H,FPIV2
CALL FSUB
JM FSINB ;IF NEGATIVE OR ZERO
JZ FSINB ;THEN ANDGLE IS REDUCED
LXI H,FPIV2 ;FABS(X)-PI
CALL FSUB
MOV E,A ;SAVE A REGISTER
LXI H,FSINX+1
MOV A,M
ANI 80H ;SIGN OF X
XRI 80H ;INVERTED
XRA B ;-SIGN(X)*(FABS(X)-PI)
MOV B,A
MOV A,E ;RESTORE A REGISTER
DCX H ;POINT TO FSINX
CALL FSTOR ;REDUCED X
CALL FZERO ;CLEAR ACCUMULATOR
JMP FSINA ;REPEAT UNTIL FABS(X) <= PI/2
;
FSINB: LXI H,FSINX
CALL FLOAD
LXI H,FSINX
CALL FMUL
CALL FCHS ;-X^2
LXI H,FMACX
CALL FSTOR ;TO MACLAURIN SERIES
MVI D,72 ;9*8, 11 TERM DISCARDED, 18 BITS PRECISION
MVI C,30 ;9*8 - 7*6
MVI B,8 ;(9*8 - 7*6) - (7*6 - 5*4)
CALL FMACE
LXI H,FMACS
CALL FLOAD
LXI H,FSINX
CALL FMUL
CPI 81H ;SEE IF TAIL NEEDS CLEANING
JC FSINC ;NO, MAGNITUDE IS < 1.0
LXI H,ACC2
XRA A
MOV M,A
INR L
MOV M,A
FSINC: CALL FTEST ;RESTORE FLAGS AND REGISTERS FOR EXIT
RET
;
;
; ARCTAN ROUTINE USING MACLAURIN SERIES
;
;
;
; ENTRY FATAN FOR ARCTAN(X), WITH X IN FLOATING POINT ACCUMULATOR
; RESULT RETURNED IN FLOATING POINT ACCUMULATOR
;
; STORAGE IN SCRATCH BANK
FATNT EQU SCRT+10H
FATNU EQU SCRT+14H
;
; FOUR LEVELS OF STACK USED
;
FATAN: CALL FTEST ;GET F.P. ACC. INTO REGISTERS
RZ
CPI 81H ;TEST EXPONENT
JC FATN1 ;RETURN TO CALLER FROM FATN1
LXI H,FONE ;1.0
CALL IDV ;1.0/X
CALL FATN1 ;ARCTAN(1/X)
LXI H,FATNU
CALL FSTOR
LXI H,FPIV2 ;PI/2
CALL FLOAD
MOV E,A ;SAVE A REGISTER
LXI H,FATNU+1 ;SIGN(T)
MOV A,M ;TO A REGISTER
ANI 80H
ORA B ;ATTACH TO PI/2
MOV B,A
MOV A,E ;RESTORE A REGISTER
LXI H,FATNT
CALL FSTOR
LXI H,FATNT
CALL FLOAD
LXI H,FATNU ;-SIGN(T)*(PI/S-FABS(T))
CALL FSUB ;=SIGN(T)*FABS(T) = T
RET
;
; EVALUATE ARCTAN OF ARGUMENTS < 1.0
FATN1: LXI H,FATNT ;POINT TO TEMP
CALL FSTOR ;TAN(T)
LXI H,FATNT
CALL FMUL ;TAN(T)^2
LXI H,FONE ;1.0
CALL FADD
CALL FSQRT
LXI H,FONE
CALL FADD ;1.0+SQRT(TAN(T)^2+1.0)
LXI H,FATNT
CALL IDV ;TAN(T/2)
LXI H,FATNT
CALL FSTOR
LXI H,FATNU
INR A ;2*TAN(T/2)
CALL FSTOR
LXI H,FATNT
CALL FMUL
CALL FCHS ;-TAN(T/2)^2
LXI H,FMACX
CALL FSTOR
MVI D,11 ;TERM 13 DISCARDED, 16 BITS PRECISION IN RANGE
MVI C,2 ;(11-9)
MVI B,0 ;(11-9)-(9-7)
CALL FMACL
LXI H,FMACS
CALL FLOAD
LXI H,FATNU
CALL FMUL
RET
;
;
;
; HYPERBOLIC COSINE ROUTINE USING MACLAURIN SERIES
;
;
;
; ENTRY FCOSH FOR COSH(X), WITH X IN THE FLOATING POINT ACCUMULATOR
; THE RESULT IS RETURNED IN THE F.P. ACCUMULATOR.
; IF FABS(X) > 88.0 THE OVERFLOW FLAG IS SET.
;
; STORAGE IN SCRATCH BANK
FCSHD EQU SCRT+0EH ;DOUBLING COUNTER
;
; THREE LEVELS OF STACK USED
;
FCOSH: CALL FTEST ;GET ARGUMENT INTO REGISTERS
LXI H,FMACX
CALL FSTOR
LXI H,FCSHD
MVI M,0
SUI 80H ;REMOVE EXPONENT OFFSET
JM FCSHA ;DOUBLING COUNT AND X ARE OK
CPI 8 ;ELIMINATE OVERSIZE DOUBLING COUNT
JP OVERF ;RETURN THROUGH OVERFLOW ROUTINE
MOV M,A ;SAVE THE DOUBLING COUNT
LXI H,FMACX
MVI M,80H
CALL FLOAD ;PUT X INTO ACC
FCSHA: LXI H,FMACX
CALL FMUL ;X^2
LXI H,FMACX
CALL FSTOR
MVI D,56 ;8*7, 10 TERM DISCARDED, 21 BITS PRECISION
MVI C,26 ;(8*7-6*5)
MVI B,8 ;(8*7-6*5) - (6*5-4*3)
CALL FMACE
FCSHB: LXI H,FCSHD ;ADDRESS THE DOUBLING COUNT
DCR M ;TALLY AT LOOP TOP
JM FCSHC ;DONE WHEN COUNT IS NEGATIVE
LXI H,FMACS ;FETCH COSH(X/2)
CALL FLOAD
LXI H,FMACS
CALL FMUL ;COSH(X/2)^2
LXI H,ACCE
INR M ;2*COSH(X/2)^2
LXI H,FONE ;-1.0
CALL FSUB ;=COSH(X)
LXI H,FMACS
CALL FSTOR
JMP FCSHB ;TEST DOUBLING COUNT
FCSHC: CALL FTEST ;RESTORE REGISTERS AND FLAGS
RET
;
;
;
; EXPONENTIAL AND HYPERBOLIC SIN ROUTINE
;
;
; SCRATCH BANK STORAGE
FSNHD EQU SCRT+0EH
FEXOV EQU SCRT+0FH
FSNHX EQU SCRT+10H
;
;
; ENTRY FEXP FOR EXP(X)
; ENTRY SSINH FOR SINH(X)
; ENTRY WITH X IN FP ACCUMULATOR
; RETURNS WITH FUNCTION IN FP ACCUMULATOR.
; IF FUNCTION EXCEEDS 2^127M OVERFLOW FLAG WILL BE SET
;
FSINH: CALL FTEST ;FETCH FP ACCUMULATOR
LXI H,FSNHX ;SAVE ARGUMENT
CALL FSTOR
LXI H,FSNHD ;ADDRESS DOUBLING COUNTER
MVI M,0
SUI 80H ;REMOVE OFFSET FROM A
JM FSNHA ;DOUBLING COUNT AND X ARE OK
CPI 8 ;ELIMINATE OVERSIZE DOUBLING COUNT
JP OVERF ;RETURN THROUGH OVERFLOW ROUTINE
MOV M,A ;SAVE DOUBLING COUNT
LXI H,FSNHX ;BRING ARGUMENT INTO RANGE
MVI M,80H
CALL FLOAD ;PUT X INTO FLOATING ACCUMULATOR
FSNHA: LXI H,FSNHX
CALL FMUL ;X^2
LXI H,FMACX
CALL FSTOR
MVI D,42 ;7*6, 9 TERM DISCARDED, 18 BITS PRECISION
MVI C,22 ;7*6-5*4
MVI B,8 ;(7*6-5*4)-(F*4-3*2)
CALL FMACE
LXI H,FMACS
CALL FLOAD
LXI H,FSNHX
CALL FMUL
LXI H,FSNHX ;SINH(X)
CALL FSTOR
LXI H,FSNHX ;SINH(X)^2
CALL FMUL
LXI H,FONE ;+1.0
CALL FADD
CALL FSQRT ;COSH(X) FOR DOUBLINE AND FOR EXP(X9
LXI H,FMACX ;TEMP
CALL FSTOR
FSNHB: LXI H,FSNHD ;ADDRESS DOUBLING COUNT
DCR M ;TALLY AT LOOP TOP
JM FSNHC ;DONE WHEN NEGATIVE
LXI H,FMACX ;COSH(X/2)
CALL FLOAD
LXI H,FSNHX ;SINH(X/2)
CALL FMUL
INR A ;2.*SINH(X/2)*COSH(X/2)
LXI H,FSNHX ;SINH(X)
CALL FSTOR
LXI H,FMACX ;COSH(X/2)
CALL FLOAD
LXI H,FMACX
CALL FMUL
LXI H,ACCE ;2.*COSH(X/2)^2
INR M
LXI H,FONE ;-1
CALL FSUB
LXI H,FMACX ;=COSH(X)
CALL FSTOR
JMP FSNHB ;TEST THE DOUBLING COUNT
FSNHC: LXI H,FSNHX
CALL FLOAD
RET
FEXP: CALL FTEST
JP FEXPP
LXI H,OVER ;SAVE OVERFLOW FLAG
MOV E,M
MVI M,0
LXI H,FEXOV
MOV M,E ;OLD FLAG TO SAVE CELL
CALL FABS
CALL FEXPP ;EXP(-X) IN ACC
LXI H,FEXOV ;GET OLD OVERFLOW FLAG BACK
MOV E,M
LXI H,OVER ;PICK UP NEW ONE TO TEST
MOV A,M
MOV M,E ;RESTORE OLD OVERFLOW FLAG
ANA A ;SET FLAGS
JNZ FZERO ;RECIPROCAL OF OVERFLOW IS ZERO
LXI H,FONE
CALL IDV ;1./EXP(-X) = EXP(X)
RET
FEXPP: CALL FSINH ;SINH(X)
LXI H,FMACX ;+COSH(X)
CALL FADD ;=EXP(X)
RET
;
;
;
; NATURAL LOGARITHM ROUTINE USING MACLAURIN SERIES
;
;
;
;
; ENTRY POINTS IN MACLAURIN SERIES
; STORAGE IN SCRATCH BANK
FLOGE EQU SCRT+0EH
FLOGX EQU SCRT+10H
;
;
; ENTRY FLOG FOR LN(FABS(X)), WITH X IN F.P. ACCUMULATOR
; RESULT IS RETURNED IN FLOATING POINT ACCUMULATOR
; IF X = 0 THE OVERFLOW FLAG IS SET
;
; 3 LEVELS OF SUBROUTINES USED
;
FLOG: CALL FABS ;FORCE ARGUMENT POSITIVE, SET ZERO FLAG
JZ OVERF ;RETURN THROUGH OVERFLOW ROUTINE
SUI 81H ;REMOVE EXPONENT OFFSET
LXI H,FLOGE
MOV M,A
MVI A,81H ;NORMALIZE ARGUMENT
LXI H,FLOGX
CALL FSTOR ;CALL IT X
LXI H,FLOGX
CALL FLOAD
LXI H,FONE
CALL FADD
LXI H,FMACS
CALL FSTOR ;X+1.0
LXI H,FLOGX
CALL FLOAD
LXI H,FONE
CALL FSUB ;X-1.0
LXI H,FMACS
CALL FDIV
LXI H,FLOGX
CALL FSTOR ;(X-1.0)/(X+1.0)
LXI H,FLOGX
CALL FMUL
LXI H,FMACX
CALL FSTOR ;((X-1.0)/(X+1.0))^2
MVI D,9 ;DISCARD 11 TERM FOR 18 BITS PRECISION
MVI C,2 ;9-7
MVI B,0 ;(9-7)-(7-5)
CALL FMACL
LXI H,FMACS
INR M ;DOUBLE THE SUM
CALL FLOAD
LXI H,FLOGX
CALL FMUL ;LOGARITHM OF FRACTIONAL PART
LXI H,FLOGX
CALL FSTOR
LXI H,FLOGE
MOV A,M
MVI B,0
MOV C,B
MOV D,B
MVI E,8 ;BINARY SCALE FACTOR FOR EXPONENT
CALL FFLOAT
LXI H,FLN2
CALL FMUL ;LOGARITHM OF 2^EXPONENT
LXI H,FLOGX ;LOG OF FRACTIONAL PART
CALL FADD
RET
;
; RANDOM NUMBER GENERATOR
;
;
RAND: ;COMPUTE NEXT RANDOM NUMBER, AND LEAVE AT SEED
LXI H,SEED
MOV C,M ;GET LEAST SIGNIFICANT BYTE
INR L
MOV B,M ;X(N) IN B,C
DCR L ;ADDRESS SEED FOR SBR2
CALL AROUT ;CALCUALTE X(N)*2053D
LXI H,CNST ;ADDRESS CONSTANT 13849
CALL SBR2
LXI H,SEED ;ADDRESS SEED AGAIN
MOV M,C ;STORE NEW SEED
INR L
MOV M,B
RET ;WITH SEED SET TO RANDOM NUMBER
;
CNST: DW 13849
;
AROUT: ;COMPUTE X(N)*2053D TO B,C
MVI D,9 ;X(N)*2**9
CALL SBR1
CALL SBR2 ;X(N)+X(N)*2**9
MVI D,2 ;2**2*(X(N)+X(N)*2**9)
CALL SBR1
CALL SBR2 ;ADD TO X(N)
RET
;
SBR1: ;FORMS (B AND C)*2**D
SUB A ;CLEAR A AND CARRY
MOV A,C ;SHIFT C LEFT
RAL
MOV C,A
MOV A,B ;SHIFT B LEFT
RAL
MOV B,A
DCR D ;TEST D=0
RZ ;IF YES, RETURN
JMP SBR1 ;NO, SHIFT AGAIN
;
SBR2: ;16-BIT ADD OF B,C TO M(H,L), RESULT TO B,C
SUB A ;CLEAR A AND CARRY
MOV A,M ;LOAD LOW BYTE
ADD C ;M(H,L)+C
MOV C,A
INR L ;M(H,L+1)
MOV A,M
ADC B
MOV B,A
DCR L ;RESTORE H,L FOR NEXT OPERATION
RET
END

2519
ASSEMBLY & COMPILE TOOLS/Basic-E/source/manual.txt Normal file
View File

File diff suppressed because it is too large Load Diff

2521
ASSEMBLY & COMPILE TOOLS/Basic-E/source/readme.md Normal file
View File

File diff suppressed because it is too large Load Diff