; FOCAL.M80 - Source to FOCAL for Z-80 and CP/M using "CROSS" mnemonics .ENABL Z80 ;Use CROSS.EXE to assemble this .LIST MB ;Include call and binary in listing ; Copyright (c) D R Banks, CSM, 1976, 1977, 1978 ; Copyright (c) Wayne Wall, CSM, 1979 ; Copyright (c) Joe Smith, CSM, 1984 ; ; Original author: Dawn Banks, DEC, (617)467-4366 ; Current Maintainer: Joe Smith, CSM (303)273-3448 ; ; Colorado School of Mines Computing Center ; 1500 Illinois, Golden, Co 80401 ; (303)273-3448 ; ; Version 1E converted to run under CP/M, March 1984 /JMS ; ; "FOCAL" is a registered trademark of Digital Equipment Corp. ; ; This version of FOCAL was written from scratch for the Z80 CPU ; and therefore does not infringe on DEC's copyright. This version ; has been released by the authors into the public domain. ;Define register pairs as 2-letter mnemonics AF=%PSW BC=%B DE=%D HL=%H ;Alternate (prime) registers AP=A BP=B CP=C DP=D EP=E HP=H LP=L MP=M AFP=AF BCP=BC DEP=DE HLP=HL ;Bit numbers B0=0 ;Lsb B7=7 ;Msb .SBTTL Feature test switches ; The following switches are symbol definitions, which when set ; to a non-zero value will turn that feature on (or off if the ; value is set to zero). .MACRO ND SYM,VAL .IFNDF SYM SYM=VAL .ENDC SYM=SYM .ENDM ND FTDEBG,-1 ;Turn on debugging features ND FTINDX,-1 ;Create an index of the line numbers ND FTEXFN,-1 ;Include extended math functions ND FTEXPF,-1 ;Include exp format I/O ND FBYTES,6 ;Number of bytes of floating point precision ; (must be 4 or 6) ND FTCPM,-1 ;Use CP/M for I/O .IFNZ FTCPM .TITLE FOCAL for the Z80 (CP/M version) ;Need to implement the following in/out device numbers: ;0 = default (whatever definition of CON: CP/M was using when FOCAL started) ;1 = TTY: (LA34 printer/keyboard connected to the VT180 printer port) ;2 = CRT: (VT100 screen/keyboard on the VT180) ;3 = BAT: (input from RDR:, output to LST:) ;4 = UC1: (in/out using the general-purpose port) ;5 = RDR:/PUN: (PTR: and PTP: connected to modem and host computer) ;6 = LST: (output only to LPT:, not allowed as console) ;7 = DSK: (input/output to file set up when FOCAL started, not a console) .ENDC .IFZ FTCPM .TITLE FOCAL for the Z80 (Digital Group version) .ENDC .MACRO PJMP ADDR JMP ADDR .ENDM .MACRO PBR RELADR JMPR RELADR .ENDM .MACRO PBNE RELADR JRNZ RELADR .ENDM .MACRO PJRZ RELADR JRZ RELADR .ENDM .MACRO PJPL ADDR JP ADDR .ENDM .MACRO PBCC RELADR JRNC RELADR .ENDM .MACRO PBCS RELADR JRC RELADR .ENDM .SBTTL Some trap vectors .IFZ FTCPM .=$010E ;Trap vector 4 (rst5) will restart FOCAL JMP START ;Go to the FOCAL start address JMP ERRORP ;Rst6 -- call error routine .=$0700 ;Put above debug monitor and friends .ENDC .IFNZ FTCPM .=$0100 ;*; ;for cpm .ENDC MEMSIZ=$47FF ;Highest memory address FOCAL will use .MACR ERROR CALL ERRORP ;Call error processor .ENDM .MACR TRAP RST 7 .ENDM .IFNZ FTINDX EOI=$FD ;End of index flag .ENDC EOP=$FE ;End of program flag EOV=$FF ;End of variable flag CR=@015 ;Code for LF=@012 ;Code for RUBOUT=@177 ;Code for rubout FP1H=$4000 ;Hi order fp for 1 .SBTTL FOCAL error codes ; ; error codes are negative ; ; IOERR=@335 ;-35 device I/O error encountered ILFRMT=@336 ;-34 illegal format spec ARG2M=@337 ;-33 second argument missing in function OUTMEM=@340 ;-32 ran out of memory space WNEXG=@341 ;-31 "write" of non-existant group UNRFUN=@342 ;-30 unrecognizable function name PFERR=@343 ;-29 parentheses error in function MNEXL=@344 ;-28 "modify" of non-existant line DONEXG=@345 ;-27 "do" of non-existant group DONEXL=@346 ;-26 "do" of non-existant line IFSYN=@347 ;-25 syntax error in "if" command ENEXL=@350 ;-24 "erase" of non-existant line UNAOP=@351 ;-23 unimplemented arithmetic operation WNEXL=@352 ;-22 "write" of non-existant line GONEXL=@353 ;-21 "goto" non-existant line BADLI=@354 ;-20 bad line number on input PRGFU=@355 ;-19 program space fouled up UNRBRK=@356 ;-18 unrecognizable trap code OVF=@357 ;-17 overflow IOVF=@360 ;-16 integer overflow UFL=@361 ;-15 useless "for" loop FBDTRM=@362 ;-14 bad terminator in "for" or "set" NOEQLS=@363 ;-13 no "=" in "for" or "set" BADVAR=@364 ;-12 bad variable name FUNILL=@365 ;-11 function illegal here NUMILL=@366 ;-10 number illegal here DBLTRM=@367 ;-9 double terminators DIVZER=@370 ;-8 divide by zero OPNMIS=@371 ;-7 operand missing - eval PMATCH=@372 ;-6 parentheses mismatch - eval OPRMIS=@373 ;-5 operator missing - eval ILLNO=@374 ;-4 illegal line number BADCOM=@375 ;-3 unrecognizable command EILLG0=@376 ;-2 illegal group zero usage LTL=@377 ;-1 line too long ; .SBTTL Starting address of FOCAL FOCAL: LXI SP,STKADR ;Initialize stack pointer LDA CONDEV ;Get device number of console CALL CONINI ;Make it current input-output device XRA A ;Get a zero STA ECHFLG ;Reset the echo LXI SP,STKADR ; setup the stack pointer LXI X,XBLOCK ;Setup offset in x register XRA A ;Zero a STA DEBGSW ;Allow trace to be enabled DCR A ;Put ff in a STA DMPSW ;Flag trace off MVI A,'W ;"w" to write line 0.0 STA COMBUF MVI A,CR STA COMBUF+1 JMP IRETN ;Do the "w" command START: LXI SP,STKADR ; setup the stack pointer LXI X,XBLOCK ;Setup offset in x register XRA A ;Zero a STA DEBGSW ;Allow trace to be enabled DCR A ;Put ff in a STA DMPSW ;Flag trace off CALL CRLF MVI A,'* ;Get the prompt CALL PRINTC ;Print it IBAR: LXI HL,COMBUF ;Reset the text pointer SHLD TXTADR ; ... IGNOR: CALL READC ;Get a character STA CHAR ;Save it CPI LF ;See if JRZ IGNOR ;Yes -- ignore it CALL PACKC ;Put it in the command buffer CPI CR ;See if JRNZ IGNOR ;If not -- go get more characters ;If so -- fall into iretn .SBTTL Here when a has been typed IRETN: LXI HL,COMBUF ;Reset the text pointer SHLD TXTADR ; ... XRA A ;Zero a STA INSW ;Flag text to come from memory DCR A ;Make it ff STA PC ;Say direct command CALL GSPNOR ;Ignore leading spaces CALL TESTN1 ;See if number or alpha JRNC GOTNUM ;Number -- go store command CPI '. ;No -- see if '.' JRNZ INPX1 ;No -- go process command ERROR ;Yes -- flag error .BYTE EILLG0 ;Illegal group zero GOTNUM: INR DBGSWX(X) ;Disable trace while packing number CALL GETLN ;Get a line number JRC IBADL ;00.00 is a bad line number JRZ IBADL ;As is gg.00 REPLIN: CALL INSERT ;Insert the line JMP START ;And go back for another line IBADL: ERROR ;Error .BYTE BADLI ;Bad line number ; ; here to process a direct command ; INPX2: CALL GETC ;Go eat the INPX1: CALL PROC ;Go process the command BIT B7,PCX(X) ;See if pc negative JRNZ START ;Restart if so CALL NXTLIN ;Setup the pointers to the next line JRC INPX2 ;Branch if more to do JMP START ;Else restart .SBTTL High level I/O routines ;"readc" inputs a character from the current input device. ;It returns with the character in the 'a' register. ;All registers are preserved. READC: PUSH BC ;Save registers PUSH DE PUSH HL PUSH X PUSH Y LXI HL,IDSP ;Get base address of input dispatch table LDA IDEV ;Get current input device number CALL CDEVD1 ;Perform device dependent code POP Y POP X POP HL ;Restore registers POP DE POP BC RET ;And return ;"printc" takes the character that is in the 'a' register and ;Outputs it to the current output device. it preserves all registers. PRINTC: PUSH AF ;Save registers PUSH BC PUSH DE PUSH HL PUSH X PUSH Y LXI HL,ODSP ;Get base addr of output dispatch table MOV B,A ;Save char a sec LDA ODEV ;Get current output device number MOV C,A ;Device number into c reg MOV A,B ;Character into a CALL CDEVD2 ;Perform device dependent code POP Y POP X POP HL ;Restore registers POP DE POP BC POP AF RET ;And return .SBTTL Here for an "if" or "on" statement ON: STA IFONSW ;Flag "on" command IFON: CALL GSPNOR ;Move to next non-blank CPI '( ;See if we have a left paren JRZ IFCNT1 ;Yes -- skip error ERROR .BYTE IFSYN ;Syntax error in if IFCNT1: CALL EVALM1 ;Go evaluate the expression LDA CHAR ;Get the last char CPI ') ;Close paren? JRZ IFCNT2 ;Yes -- go finish command ERROR .BYTE PMATCH ;Unbalanced parentheses IFCNT2: CALL GETC ;Eat the close paren BIT B7,FLACM1(X) ;Test sign bit of the flac JRNZ IFXCT ;If negative - go do it IF3: LDA CHAR ;Get the character CPI ', ;See if comma JRZ IF1 ;Exit if so CPI '; ;end of command? JZ PROC ;End command CPI CR ;? RZ ;Just return if so CALL GETC ;No -- get another character JMPR IF3 ;And loop until comma IFCOM=ON IF1: CALL GETC ;Move past the comma CALL CHKZER ;See if flac is zero CALL ZERFLC ;Zero the flac so next time we will win JRNZ IF3 ;And loop for another comma IFXCT: CALL GETLNS ;Go get the line number PUSH AF ;Save the ps CALL EATECM ;Eat to the end of the command POP AF ;Restore af JPE PROC ;Branch if no line number given PUSH AF ;But leave it on the stack LDA IFONSW ;Was this an on command? CPI 'O ; ... JRZ IF2 ;Yes -- go do the line(s) POP AF ;Restore af JMP GOTO1 ;If command, go to line IF2: POP AF ;Restore af PBR DO1 ;And go do the line(s) ; ; return command ; RETURN: MVI PCX(X),$FF ;Put ff in pc RET ;Return QUIT=START .SBTTL Modify -- here on a modify command MODIFY: CALL GETLNS ;Get the line number specified JRC BADMOD ;Branch if bad line number JRNZ MODNOK ;Brach if ok BADMOD: ERROR .BYTE MNEXL ;Modify of non-existant line MODNOK: CALL FINDLN ;Go find the line JRNC BADMOD ;Connot find it - error .IFNZ FTINDX LHLD TXTADR ;Get the text pointer INX HL ;Move past the line number .ENDC INX HL ;Correct the text pointer SHLD TXTAD2 ;Save as the new text address CALL PRNTLC ;And print the line number MBAR: LXI DE,COMBUF ;Point to the command buffer LXI BC,127 ;Max of 127 chars to a line SDED TXTADR ;Save combuf as second text pointer MNXTC: CALL READC ;Get a char (do not echo) STA CHAR ;Save it as the current character CPI LF ;See if JRZ MLOOK1 ;Yes -- finish line CPI @033 ;See if JRZ MLOOK ;Yes -- go search line CALL PACKC1 ;No -- go pack the character CPI '_ ;See if underscore JRZ MBAR ;Yes -- erase line CPI CR ;? JRNZ MNXTC ;No -- go for more MENDL: INR DBGSWX(X) ;Disable trace for insert LXI HL,COMBUF+1 ;Point to combuf+1 CALL INSER0 ;Go insert the new line JMP START ;And restart FOCAL .SBTTL Modify -- search for a character on the line being modified (mlook) MLOOK: CALL READC ;Get the search character MLOOK1: STA MSCHAR ;Save as the search character MLOOK2: LHLD TXTAD2 ;Get the text pointer LDED TXTADR ;Get the pointer to the program text LDI ;Transfer a character SHLD TXTAD2 ;Save the pointers SDED TXTADR ; ... DCX HL ;Backspace to char just xfered MOV A,M ;Get the character pointed to CALL PRINTC ;Echo it CMP MSCHRX(X) ;See if it matches the search character JRZ MNXTC ;Yes -- end search CPI CR ;See if JRNZ MLOOK2 ;No -- punt this MVI A,LF ;Get a CALL PRINTC ;Print it JMPR MENDL ;And end the line .SBTTL Do command DO: CALL GETLNS ;Get the line number DO1: EXAF ;Save the ps for a min LXI HL,PC ;Point to the pc MVI B,4 ;Say push 4 words DO2: MOV D,M ;Get 1st byte INX HL ;Increment pointer MOV E,M ;Get 2nd byte PUSH DE ;Push them INX HL ;Increment the pointer DJNZ DO2 ;Loop for all words EXAF ;Restore the ps JRC DOGRP ;Go do a group if carry set JRZ DOGRP ;Or do all DOONE: CALL FINDLN ;Go find the line JRC DOCNT1 ;Branch if we found it ERROR .BYTE DONEXL ;Do of nonexistant line DOCNT1: CALL NEWLIN ;Setup the new line CALL PROCESS ;Go do it DOCONT: MVI B,4 ;Restore 4 bytes LXI HL,PC+7 ;Setup the address DOCON0: POP DE ;Restore de MOV M,E ;Restore 2nd byte DCX HL ;Decrement the pointer MOV M,D ;Restore 1st byte DCX HL ;Decrement the pointer DJNZ DOCON0 ;Loop for all bytes JMP PROC ;And go process next command DOGRP: CALL FINDLN ;Find the smallest line of the group LDA TGRP ;Get the group number CMP GRPNOX(X) ;See if same group JRZ DOGRP1 ;Branch if so ERROR .BYTE DONEXG ;Do of nonex group DOGRP1: PUSH AF ;Save it on the stack DOGRPC: CALL NXTLIN ;Setup pointers for next line JRNC ENDGRP ;Branch if end of program POP AF ;Get group back PUSH AF ;And push it ORI 0 ;Are we doing group zero? JRZ DONEXT ;Yes, any line will do CMP PCX+1(X) ;See if we are still in the same group JRNZ ENDGRP ;Exit if not DONEXT: CALL PROCESS ;Go process the line BIT B7,PCX(X) ;Test sign bit on pc JRZ DOGRPC ;Branch if more to do ENDGRP: POP AF ;Restore af JMPR DOCONT ;And return from do .SBTTL Erase command ERASE: CALL SPNOR ;Ignore leading spaces CPI 'A ;See if all JRZ EALL ;Yes -- erase everything CALL GETLN ;Get the line number LHLD TXTADR ;Get the text pointer PUSH HL ;Save it JRC EVAR ;Erase the variables if no arg JRZ EGRP ;Branch if erase a group CALL FINDLN ;Go find the line JRC ERCONT ;Go it ERROR .BYTE ENEXL ;Erase of nonex line ERCONT: CALL DELETE ;Erase the line JMP START ;And go to command mode EVAR: LHLD VARBEG ;Get address of the beginning of variables MVI M,EOV ;Store the mark SHLD VAREND ;Save it as the end of the list POP HL ;Restore hl SHLD TXTADR ;Restore text pointer JMP PROC ;And continue EALL: LXI HL,PRGINI ;Get beginning of program text SHLD PRGEND ;Say end of program MVI M,EOP ;Write end of program INX HL ;Increment pointer .IFNZ FTINDX ;Include this is index wanted CALL MAKIDX ;Reconstruct the index .ENDC .IFZ FTINDX MVI M,EOV ;Set end of variables SHLD VARBEG ;Say beginning of variables SHLD VAREND ;And say end .ENDC JMP START ;And restart FOCAL ELINE: CALL DELETE ;Delete the line EGRP: CALL TXTINI ;Must reset text pointer to start of program CALL FINDLN ;Go find the group LDA TGRP ;Get the wanted group number CMP GRPNOX(X) ;See if it matches JRZ ELINE ;Delete it if so JMP START ;Done .SBTTL Write command WRITE: INR DBGSWX(X) ;Disable trace CALL GETLNS ;Get the line or group LHLD TXTADR ;Get the text pointer PUSH HL ;Save it LDA CHAR ;Get the last char PUSH AF ;Save it too JRC WALL ;Write all JRNZ WLINE ;Write a line WGRP: CALL FINDLN ;Go find the group LDA TGRP ;Get the desired group CMP GRPNOX(X) ;Is it the one we want? JRZ WGRP1 ;Branch if yes ERROR .BYTE WNEXG ;Write of nonex group WGRP1: CALL WGRPO ;Output the group WEXIT: CALL CRLF ;Type a crlf CALL CRLF ;Twice DCR DBGSWX(X) ;Enable trace POP AF ;Restore STA CHAR ; the last char POP HL ;Get the text SHLD TXTADR ; pointer back JMPR PROC ;And continue processing WLINE: CALL FINDLN ;Go find the line JRC WLINE1 ;Branch if we found it ERROR .BYTE WNEXL ;Write of nonex line WLINE1: CALL WONE ;Write the line JMPR WEXIT ;And exit WALL: CALL FINDLN ;Go find 00.00 WALL1: CALL WGRPO ;Output this group JRZ WEXIT ;Branch if eop STA TGRP ;Make next group the one JMPR WALL1 ;And go do it .SBTTL Write command subroutines WGRPO: CALL CRLF ;Type a WGRPO1: CALL WONE ;Write one JRZ WEXGRP ;Branch if eop CMP TGRPX(X) ;Is the next line same group? JRZ WGRPO1 ;Loop if so WEXGRP: RET ;Return WONE: CALL PRNTLC ;Output the line number WONEC: CALL GETC ;Get a char CPI CR ;See if JRZ WONE0 ;Branch if so CALL PRINTC JMPR WONEC ;Loop for all chars WONE0: MOV A,M ;Get char pointed to CPI EOP ;See if end of program RET ;Return with z setup .SBTTL Goto command and process GOTO: CALL GETLNS ;Get the line number GOTO1: CALL FINDLN ;Try to find it JRC GCONT ;We found it ERROR .BYTE GONEXL ;Got nonex line GCONT: CALL NEWLIN ;Go setup the new line ;* pfall * into proces ; ; command processor ; PROCES: CALL GETC ;Go get a char PROC: CALL ROOMCK ;Check the stack LDA CHAR ;Get the last char read CPI CR ;? RZ ;If so, then return CALL GLTEST ;Is the char a terminator? JRZ PROCES ;If so, ignore it PUSH AF PTERM1: CALL GLTEST ;Check for terminator JRZ PTERM2 ;Yes -- leave loop CALL GETC ;Get a char JMPR PTERM1 ;And skip over rest of command name PTERM2: POP AF ;Restore saved char LXI HL,COMTAB ;Get command table address LXI BC,COMLEN ;Get size of table CCIR ;Search it JRNZ ILLCOM ;Illegal command if no match LXI HL,DSPEND ;Get last loc of dispatch SLAR C ;Shift byte count (mult by 2) ORA A ;Clear carry DSBC BC ;Make offset in table MOV E,M ;Get low order addr INX HL ;Increment pointer MOV H,M ;Get hi order MOV L,E ;Move low a bit PCHL ;And dispatch command .SBTTL Gltest ; ; gltest exits with z set if the char in the accumulator is ; a termiantor (space comma, or semi-colon) ; GLTEST: CPI ' ;Space? RZ ;Return if so CPI ', ;Comma? RZ ; ... TSTEOC: CPI '; ;semi-colon? RZ ; ... CPI CR ;? RTS2: RET ;Return with z set ; ; illegal commands come here ; ILLCOM: ERROR .BYTE BADCOM ;Unrecognizable command ; ; comment command ; COMMNT=EATCR ;Temp hack .SBTTL Type/ask -- type the variable list TDUMP: CALL VARINI ;Init pointer to start of variable list TDNEXT: CALL CRLF ;Start new line LHLD VARADR ;Get the address of the next variable MOV A,M ;Get the variable name CPI EOV ;End of list? JZ TASK4 ;Branch if so PUSH AF ;Save it SRLR A ;Extract alpha part SRLR A ; ... SRLR A ; ... ORI $40 ;Make it ascii CALL PRINTC ;Print it POP AF ;Restore name ANI 7 ;Mask off alpha ORI $30 ;Make an ascii digit CALL PRINTC MVI A,'( ;Get open paren CALL PRINTC ;Output it CALL ZERFLC ;Zero flac INX HL ;Get the subscript MOV A,M ; ... STA FLCM3 ;Put in hi order byte INX HL ;Increment pointer MOV A,M ;Get next byte STA FLCM4 ;Put it in the ac CALL INTOUT ;Output the integer in flacm3-4 MVI A,') ;Close paren CALL PRINTC MVI A,'= ;Get equals CALL PRINTC CALL FETVAR ;Move the variable into flac INX HL ;Point to next variable SHLD VARADR ;And update pointer CALL FLOUT ;Print it JMPR TDNEXT ;Loop for more .SBTTL Type/ask -- type and ask commands TASK1: CALL GETVAR ;Go get the variable LDA CHAR ;Get delimiter PUSH AF ;And save it INR INSWX(X) ;Flag input from keyboard ASKAGN: LHLD VARADR ;Get the variable pointer PUSH HL ;Push it on the stack CALL EVALM1 ;Go get the user supplied data POP HL ;Restore SHLD VARADR ; the variable pointer LDA CHAR ;Get the delimiter from eval CPI @137 ;Back arrow? JRZ ASKAGN ;Yes -- ask him again CALL PUTVAR ;Place the data in the variable DCR INSWX(X) ;Reset from keyboard flag POP AF ;Restore af STA CHAR ;And put it back where we got it JMPR TASK ;And go for next arg .SBTTL Type/ask -- dispatch tables for type and ask commands TSKDSP: JMPR TDUMP JMPR TCRLF JMPR TCR JMPR TQUOT JMPR TASK4 JMPR TPROC JMPR TPC1 JMPR TFRMT TDSPND=. ;End of dispatch table TSKLST: .BYTE '$ ;Dump variable list .BYTE '! ;Crlf .BYTE '# ; only .BYTE '" ;Quoted string .BYTE ', ;Ignore commas .BYTE '; ;end of command .BYTE CR ; .BYTE '% ;Set format TSKSIZ=.-TSKLST ;Size of list ASK=TYPE .SBTTL Type/ask -- entry point for type and ask TYPE: STA ATSW ;Save command char TASK: XRA A ;Zero a STA DEBGSW ;Enable trace CALL SPNOR ;Get next non-blank LXI HL,TSKLST ;Get list of possible chars LXI BC,TSKSIZ ;And size of list CCIR ;See if a match JRZ DSPASK ;Yes -- go dispatch LDA ATSW ;Get ask/type switch CPI 'A ;See if ask JRZ TASK1 ;Yes -- go do ask dependent stuff CALL EVAL ;No -- go evaluate the expression CALL FLOUT ;And go output the result LDA CHAR ;Get the terminator CPI ') ;Flush bad chars JRZ TASK4 ; ... CPI '= ; ... JRZ TASK4 ; ... CPI '. ; ... JRZ TASK4 ; ... JMPR TASK ;Otherwise, loop DSPASK: SLAR C ;Shift char count left LXI HL,TDSPND-2 ;Get end of dispatch table DSBC BC ;Subtract bytes remaining*2 PCHL ;And go to it TCRLF: MVI A,LF ;Get a CALL PRINTC ;Output it TCR: MVI A,CR ;Get a CALL PRINTC ;Output it TASK4: CALL GETC ;Skip over this char JMPR TASK ;And go get more TQUOT: INR DBGSWX(X) ;Disable trace TQUOT1: CALL GETC ;Get a char CPI '" ;See if close quote JRZ TASK4 ;Yes -- done CPI CR ;End of line? JRZ TPC1 ;Yes -- done CALL PRINTC ;No -- just output the char JMPR TQUOT1 ;And loop until out of this mess TPC1: MVI DBGSWX(X),0 ;Reset the debug switch RET ;And exit process TPROC: JMP PROCES ;Continue processing the line TFRMT: CALL GETC ;Skip over % CALL GETLN ;Get a line number LDA GRPNO ;Get the first half CPI 11 ;See if ge 11 JM TFRMT1 ;No -- ok ILLSPC: ERROR .BYTE ILFRMT ;Illegal format specification TFRMT1: STA MANDIG ;Save it as size of integer LDA LINENO ;Get the line number CPI 9 ;See if wrong JP ILLSPC ;Yes -- error STA NFRAC ;No -- just store JMP TASK ;And go for next arg .SBTTL Set/for -- set and for commands FOR: CALL GETVAR ;Get the variable name in question LDA CHAR ;Get the terminator CPI '= ; = sign? JRZ FOR2 ;Yes -- ok so far ERROR .BYTE NOEQLS ;No = in for or set FOR2: LHLD VARADR ;Get the variable's address PUSH HL ;Save it for a while CALL EVALM1 ;Go call eval POP HL ;Restore the variable address SHLD VARADR ; ... CALL PUTVAR ;Store the new value LDA CHAR ;Get the terminator back CPI ', ;Comma? JRZ FINCR ;Yes -- go process for command CPI '; ;end of command? JZ PROCES ;Exit now if done CPI CR ;? RZ ;Exit if so BTFOR: ERROR .BYTE FBDTRM ;Bad terminator in for or set SETCOM=FOR .SBTTL Set/for -- here to process for loop FINCR: LHLD VARADR ;Get the address of the output var PUSH HL ;Save it for a min CALL EVALM1 ;Go evaluate next expr LDA CHAR ;Get terminatot back CPI ', ;Did he give an increment? JRZ FLIMIT ;Yes -- go get the upper limit CPI '; ;did he give more on this line? JRZ FINCR1 ;Yes -- go do rest CPI CR ;? JRNZ BTFOR ;No -- bad terminator ERROR .BYTE UFL ;Useless for loop FINCR1: LXI HL,FP1H ;Get hi order part of floating '1' PUSH HL ;Push it LXI HL,0 ;Get low part (zero) PUSH HL ;Save it .IFZ FBYTES-6 PUSH HL ; ... .ENDC JMPR FSHORT ;Go do the rest of the for command FLIMIT: CALL PUSHF ;Put flac on the stack CALL EVALM1 ;Get last arg FSHORT: CALL PUSHF ;Save the upper limit on the stack FCONT: LHLD TXTADR ;Get the text pointer PUSH HL ;Put it on the stack CALL PROCES ;Go process the command POP HL ;Restore the text pointer SHLD TXTADR ; ... POP HL ;Restore upper loop limit .IFZ FBYTES-6 SHLD PTMP4 ; ... POP HL ; ... .ENDC SHLD PTMP2 ; ... POP HL ; ... SHLD PTMPX ; .. CALL POPIV ;Restore increment CALL PUSHIV ;And save it again CALL FETVAR ;Get the current value CALL FADD ;Add in the increment CALL PUTVAR ;And go store the result LHLD PTMP2 ;Get the upper limit SHLD FTMP2 ; and put it in the temp ac LHLD PTMPX ; ... SHLD FTMPX ; ... CALL FSUB ;Subtract counter from hi order BIT B7,FLACM1(X) ;See if negative result JRZ MORFOR ;No -- do more CALL POPIV ;Yes -- clean up stack PJMP EATCR ;Go eat the rest of the command and return MORFOR: LHLD PTMPX ;Save upper limit PUSH HL ; ... LHLD PTMP2 ; ... PUSH HL ; ... .IFZ FBYTES-6 LHLD PTMP4 ; ... PUSH HL ; ... .ENDC JMPR FCONT .SBTTL Getln -- get a line number from the program text. ; ; returns with: ; c=1 if "all", otherwise it returns with z=1 if group number ; given, but no line number, c=0 and z=0 if both given. ; GETLNS: CALL SPNOR ;Ignore leading spaces GETLN: CALL TESTN ;Go see if a digit JRC GETLN2 ;No -- use eval XRA A ;Zero a STA LINENO ;Assume initial line number CALL GETL1 ;Get group STA GRPNO ;Save it LDA CHAR ;Get terminator CPI '. ;Period? JRNZ GOTLN0 ;No -- we got it CALL GETL ;Get the line number STA LINENO ;Save it LDA NUMDIG ;Get the number of digits typed CPI 1 ;See if one JRNZ GOTLN0 ;No -- skip this LDA FLCM4 ;Get low byte PUSH AF ;Save it ADD A ;Shift left ADD A ; twice POP BC ;Restore number ADD B ;Add it in ADD A ;Shift again STA LINENO ;Store new line number GOTLN0: XRA A ;Clear a and carry LDA GRPNO ;Get the group number ORA LINNOX(X) ;Or in the line number JRZ GOTALL ;If zero - say all LDA GRPNO ;Bad if group number is zero CPI 0 ; ... JRZ BADLNO ;Branch if so LDA LINENO ;Get the line number CPI 0 ;Set z accordingly RET ;And return GOTALL: STC ;Set the carry RET ;And return with c and z set GETL: CALL GETC ;Get next char GETL1: CALL NIN ;Get an integer CKLNSZ: LXI HL,FLCM1 ;Point to flac MVI B,3 ;Check 3 bytes XRA A ;Zero ac CKLNS0: CMP M ;See if byte pointed to is zero JRNZ BADLNO ;Error if not INX HL ;Otherwise -- bump pointer DJNZ CKLNS0 ;And try next MOV A,M ;Get the last byte BIT B7,A ;See if out of range RZ ;Return if not ;* pfall * into badlno BADLNO: ERROR .BYTE ILLNO ;Illegal line number .SBTTL Getln -- call eval to get a line number GETLN2: CALL EVAL ;Go evaluate expression GETLN1: CALL PUSHF ;Save flac CALL GTFP5 ;Get floating .5 MVI C,2 ;Point to 10^2 CALL GSTEN ;Get power of ten CALL SWAP ;Swap ftmp and flac CALL FDIV ;Divide it CALL POPT ;Restore flac CALL FADD ;Add in rounding CALL PUSHF ;Save flac again CALL FIX ;Make an integer LDA FLCM4 ;Get low byte STA GRPNO ;Save group number CALL FLOAT ;Re-float it CALL POPT ;Restore flac CALL FSUB ;Subtract it MVI C,2 ;Get 10^2 CALL GSTEN ; into ftmp CALL FMULT ;Multiply by 100 CALL FIX ;Fix the number LDA FLCM4 ;Get low byte STA LINENO ;Save new line number PBR GOTLN0 ;And go clean up .SBTTL Prntln - print a line number PRNTLC: CALL CRLF ;Go type PRNTLN: LHLD TXTADR ;Get the text pointer MOV A,M ;Get the group number CPI 0 ;See if zero JRNZ PRNTL1 ;Branch if not PJMP NEWL0 ;Adjust text pointer and return PRNTL1: MVI B,10 ;Max zeros to suppress CALL PHALF ;Print half the line number MVI A,'. ;Get a period CALL PRINTC ;Print it MVI B,8 ;Max zeros to suppress MVI C,'0 ;Put ascii zero as leading zero char LHLD TXTADR ;Get the text pointers PHALF: CALL ZERFLC ;Zero the flac MOV A,M ;Get the line number STA FLCM4 ;Put in flac INX HL ;Increment the pointer SHLD TXTADR ;Save the new pointer PNUM: PJMP NOUT ;Print the number .SBTTL Findln - find a line in the program text ; ; findln -- returns with c=1 if the line number was found ; txtad2 points to the group number. ; returns with c=0 if the line was not located ; txtad2 points to the group number of next highest line ; .IFZ FTINDX ;Include if no index FINDLN: CALL TXTINI ;Go init text pointers .ENDC ;End ifzero ftindx .IFNZ FTINDX ;Include if index FINDLN: LHLD IDXBEG ;Get the beginning of the index FNEXT: ;Put label here .ENDC CHKLIN: MOV A,M ;Get the group number .IFZ FTINDX ;Include if no index CPI EOP ;See if end of program .ENDC ;End .ifz ftindx .IFNZ FTINDX ;Include if index CPI EOI ;See if end of index .ENDC ;End .ifnz ftindx JRZ NOFIND ;Yes -- can't find it INX HL ;Increment the memory pointer MOV E,M ;Put line number in the low order MOV D,A ;Put group number in hi order SDED TLINE ;Save for write PUSH HL ;Save hl LHLD LINENO ;Get the line and group numbers ORA A ;Clear carry DSBC DE ;Subtract what we found POP HL ;Restore hl .IFNZ FTINDX ;Include if index INX HL ;Bump hl MOV E,M ;Get the low order INX HL ;Bump the pointer again MOV D,M ;Get the hi order INX HL ;Point to next entry SDED TXTADR ;Update the text pointer SDED TXTAD2 ; both of them .ENDC JRZ FOUNDL ;We found it JP FNEXT ;It may be ahead .IFZ FTINDX NOFIND: .ENDC NOFND1: ORA A ;Clear carry flag FNEXIT: RET ;And return .IFZ FTINDX FNEXT: CALL EATCR ;Go eat to JMPR CHKLIN ;Go try this line .ENDC FOUNDL: STC ;Set the carry flag RET ;And return .IFNZ FTINDX NOFIND: LHLD PRGEND ;Get addr of end of program SHLD TXTADR ;Setup text pointers SHLD TXTAD2 ; ... JMPR NOFND1 ;And exit .ENDC .SBTTL Makidx - make the line number index for the program .IFNZ FTINDX ;Include only if ft switch set ; ; this routine creates the line number index just above the ; program text area. its format is 2 bytes of line number ; followed by 2 bytes of program text pointer. the list is ; terminated by the eoi mark. ; MAKIDX: LHLD TXTADR ;Get text pointer PUSH HL ;Save it LHLD PRGEND ;Get the end of the program INX HL ;Bump pointer SHLD IDXBEG ;Make it the start of the index XCHG ;Put it in de CALL TXTINI ;Init the program text pointers MAKLOP: MOV A,M ;Get group number CPI EOP ;See if end of the program JRZ MAKDON ;Done if so STAX D ;Store it in the index table INX HL ;Point to the line number INX DE ; in the index too MOV A,M ;Get the line number STAX D ;Store in the table INX DE ;Bump index pointer DCX HL ;Set pointer back to the beginning of the line MOV A,L ;Get the low order of the address STAX D ;Store in memory INX DE ;Point to 3rd byte MOV A,H ;Get hi byte STAX D ;Store in the index INX DE ;Point to next entry INX HL ;Move past INX HL ; the line number SHLD TXTADR ;Save as new text pointer CALL EATCR ;Go to the next line JMPR MAKLOP ;Loop until eop MAKDON: XCHG ;Get index pointer in hl SHLD IDXEND ;Put in end of index pointer MVI M,EOI ;Put flag in the table INX HL ;Point to varbeg MVI M,EOV ;Make end of variables SHLD VARBEG ;Setup SHLD VAREND ; the pointers POP HL ;Restore the text pointer SHLD TXTADR ; ... RET ;And return .ENDC .SBTTL Eatcr - eat to the end of the line EATCR: EATCR1: EATCRC: LXI BC,0 ;Large number of bytes MVI A,CR ;Code for LHLD TXTADR ;Get text pointer CCIR ;Find the JRNZ TXTFU ;None????? SHLD TXTADR ;Save the new text pointer SHLD TXTAD2 ;Just for kicks RET TXTFU: ERROR .BYTE PRGFU ;Text area fouled up EATEC1: CALL GETC ;Get a char JMPR EATECC ;Skip next inst EATECM: INR DBGSWX(X) ;Disable trace EATECC: LDA CHAR ;Get the char CALL TSTEOC ;See if eol char JRNZ EATEC1 ;Branch if not DCR DBGSWX(X) ;Reset trace flag RET ;And return .SBTTL Push pop routines ; ; pushiv -- push variable addr on stack ; PUSHIV: LHLD VARADR ;Get varadr XTHL ;Exchange with return addr EXX ;Swap regs CALL PUSHT ;Push ftmp EXX ;Restore return addr PCHL ;And return ; ; popiv -- pop variable pointer ; POPIV: POP HL ;Restore EXX ;Save return addr CALL POPT ;Restore ftmp POP HL ;Restore varadr SHLD VARADR ;Put it in memory EXX ;Restore return addr PCHL ;And return .SBTTL Putvar - put number in flac into variable PUTVAR: LHLD VARADR ;Get addr of variable INX HL ;Add two INX HL ;To skip name INX HL ;And subscript PUTVA0: LDA FLCEXP ;Move the exponent MOV M,A ;Store it INX HL ;Increment mem pointer LDA FLCM1 ;And move the MOV M,A ; mantissa INX HL ; ... LDA FLCM2 ; ... MOV M,A ; ... INX HL ; ... LDA FLCM3 ; ... MOV M,A ; ... .IFZ FBYTES-6 INX HL ; ... LDA FLCM4 ; ... MOV M,A ; ... INX HL ; ... LDA FLCM5 ; ... MOV M,A ; ... .ENDC RET ;And return .SBTTL Fetvar - get variable's value into flac ; FETVAR: LHLD VARADR ;Get address of variable INX HL ;Add INX HL ; three INX HL ;To skip name and subscript GETVA0: MOV A,M ;Move exponent STA FLCEXP ; ... INX HL ; ... MOV A,M ;And STA FLCM1 ; then INX HL ; the MOV A,M ; mantissa STA FLCM2 ; ... INX HL ; ... MOV A,M ; ... STA FLCM3 ; ... .IFZ FBYTES-6 INX HL ; ... MOV A,M ; ... STA FLCM4 ; ... INX HL ; ... MOV A,M ; ... STA FLCM5 ; ... .ENDC RET ;And return .SBTTL Misc text pointer routines ; ; init the text pointer ; TXTINI: LXI HL,PRGBEG ;Beginning of stored text SHLD TXTADR ;Save it RET ;And return ; ; newlin -- setup text pointers and pc for new line ; NEWLIN: LHLD LINENO ;Get the line number and group number SHLD PC ;Save the pc LHLD TXTADR ;Get text pointer NEWL0: INX HL ;Punt the line INX HL ; nuumber SHLD TXTADR ; ... RET ;Return ; ; nxtlin -- setup text pointers to next line number ; NXTLIN: LHLD TXTADR ;Setup pointer MOV A,M ;Get the char CPI EOP ;See if end of program JRZ NONEXT ;Branch if none left STA PC+1 ;Store group number INX HL ;Incr pointer MOV A,M ;Get line number STA PC ;Save it INX HL ;Skip over line number SHLD TXTADR ;Save new pointer STC ;Say we found it RET ;And return NONEXT: ORA A ;Clear carry flag RET ;Return ; ; varini -- initialize the variable pointer ; VARINI: LHLD VARBEG ;Get start of variable list SHLD VARADR ;Make it the pointer RET ;And return .SBTTL Text manipulation -- delete a line of program text DELETE: LHLD TXTADR ;Get the text pointer PUSH HL ;Push it CALL NEWL0 ;Move past the line number CALL EATCR ;Skip to end of line to zap POP HL ;Restore text pointer SHLD TXTADR ;Save it in memory LHLD PRGEND ;Get the end of the program INX HL ;Point to next loc LDED TXTAD2 ;Get second text pointer ORA A ;Clear carry DSBC DE ;Make a byte count MOV B,H ;Move byte count MOV C,L ; ... LHLD TXTAD2 ;Get second pointer back LDED TXTADR ;Get old text address LDIR ;Move everything XCHG ;Get new bov in hl .IFZ FTINDX SHLD VARBEG ;Flag beginning of variables SHLD VAREND ;And end of variable MVI M,EOV ;Flag eov .ENDC DCX HL ;Point to eop SHLD PRGEND ;Update pointer .IFZ FTINDX RET ;Return .ENDC .IFNZ FTINDX PJMP MAKIDX ;Make the index and return .ENDC .SBTTL Text manipulation -- insert a line into the program text area INSERT: LHLD TXTADR ;Get the text pointer INSER0: PUSH HL ;Save it CALL FINDLN ;Go find the line JRNC INSCNT ;Branch if line does not exist CALL DELETE ;It does -- go delete it INSCNT: POP HL ;Restore the text pointer DCX HL ;Decrement to line number delimiter PUSH HL ;And save it again LXI BC,0 ;Set byte count to zero MVI A,CR ;Get code for CCIR ;Find it in combuf MOV A,C ;Get -number of bytes in a NEG ;Negate it PUSH AF ;Save it for a while ADI 2 ;Make room for line number MOV C,A ;Put it back in bc INR B ;Set b to zero (had ff) LHLD PRGEND ;Get top of text DAD BC ;Figure place to move to .IFZ FTINDX PUSH HL ;Put hl on the stack POP DE ; and pop it into de INX HL ;Point to beginning ot variables SHLD VARBEG ;Say beginning of variables SHLD VAREND ; and end also MVI M,EOV ;Put marker in .ENDC .IFNZ FTINDX XCHG ;Put it in de .ENDC LHLD PRGEND ;Get end back LBCD TXTADR ;Get low addres of move ORA A ;Clear carry DSBC BC ;Make byte count PUSH HL ;Move it into POP BC ; bc INX BC ;Jock count by one LHLD PRGEND ;Get end of text back SDED PRGEND ;And update the pointer LDDR ;Move the text up in core LHLD TXTADR ;Get place to put line LDA GRPNO ;Get the group number MOV M,A ;Store it in memory INX HL ;Bump counter LDA LINENO ;Get the line number MOV M,A ;Store it INX HL ;Bump counter again XCHG ;And put pointer in de POP AF ;Restore byte count MVI B,0 ;Set it up MOV C,A ; properly POP HL ;And restore where the line is coming from LDIR ;Move the new line SHLD TXTADR ;Leave pointing to next line .IFZ FTINDX PJMP ROOMCK ;Check prog space and return .ENDC .IFNZ FTINDX PJMP MAKIDX ;Create the index then return .ENDC .SBTTL Packc -- pack a char into the input buffer PACKC: LDA CHAR ;Get the char into the ac PACKC1: LHLD TXTADR ;Get the text pointer CPI RUBOUT ;Rubout? JRZ RUB1 ;Yes -- go process it CPI '_ ;See if delete line JRZ RUBLIN ;Yes -- go destroy the line MOV M,A ;Store char into memory BIT B7,EFLGX(X) ;See if we echo chars JRNZ PCKRUB ;No -- skip this CALL PRINTC ;Echo the char CPI CR ;? JRNZ PCKRUB ;No -- skip this MVI A,LF ;Get a line feed CALL PRINTC ;Print it PCKRUB: INX HL ;Increment the pointer MVI A,&$FF ;Get max line size CMP L ;See if we are there JRNZ PCKRET ;No -- everything is ok ELTL: ERROR .BYTE LTL ;Line too long PCKRET: SHLD TXTADR ;Restore text pointer LDA CHAR ;And restore char RET ;And return .SBTTL Packc -- process rubout and underscore RUB1: MVI A,&$FF ;Point to combuf DCX HL ;Decrement memory pointer CMP L ;See if we went too far JRZ PCKRUB ;Yes -- fix it CALL RUB2 ;No -- do a rubout JMPR PCKRET ;And return RUB2: MVI A,@010 ;Get a backspace CALL PRINTC ;Output it MVI A,@040 ;Get a space CALL PRINTC MVI A,@010 ;And another backspace CALL PRINTC ; ... RET ;Then return RUBLIN: MVI A,&$FF ;Point to combuf DCX HL ;Decrement memory pointer CMP L ;See if done JRZ PCKRUB ;Yes -- exit CALL RUB2 ;No -- do a rubout JMPR RUBLIN ;And loop until done .SBTTL Gspnor - get the next non-blank character GSPNOR: CALL GETC ;Get a character SPNOR: LDA CHAR ;Get char into ac SPNOR1: CPI ' ;See if space JRZ GSPNOR ;Loop if so RET ;Return ; ; getc -- get a char from memory, echo if trace is on GETCX: BIT B0,DBGSWX(X) ;Test trace switch JRNZ GETC1 ;Jump if trace disabled LDA DMPSW ;Get the state of the dump switch XRI $FF ;Flip it STA DMPSW ;And store the new value GETC: BIT B0,INSWX(X) ;Test where it comes from JRZ GETCC ;Get it from memory CALL READC ;Input it from the keyboard CALL PRINTC ;And echo it STA CHAR ;Save the new char CPI CR ;? RNZ ;No -- just return now MVI A,LF ;Yes -- get a CALL PRINTC ;Output it MVI A,CR ;Get the back RET ;And return GETCC: LHLD TXTADR ;Get thhe text pointer MOV A,M ;Get the next char from memory INX HL ;Increment the pointer SHLD TXTADR ;And save new pointer CPI '? ;Quest mark? JRZ GETCX ;Yes -- go handle GETC1: STA CHAR ;Store the new char LDA DEBGSW ;Get the debug switch ORA DMPSWX(X) ;Or in the dump switch JRNZ GETRT1 ;Jump if we do not print the char LDA CHAR ;Get the char back CALL PRINTC ;Echo the char CPI CR ;? RNZ ;No -- exit MVI A,LF ;Yes -- get a CALL PRINTC ;Print it GETRT1: LDA CHAR ;Get the char back RET ;And return .SBTTL Testn - see if the char in a is a digit TESTN1: ;Hack to resolve u errors TESTN: LDA CHAR ;Get the char XRI $30 ;Convert to bcd if a digit CPI $0A ;See if larger than ascii 9 LDA CHAR ;Restore temp JP TESTN2 ;Jump if so ORA A ;Clear carry RET ;And return TESTN2: STC ;Clear carry RET ;And return CRLF: MVI A,CR ;Get a CALL PRINTC ;Print it MVI A,LF ;Get a CALL PRINTC RET ;And return .SBTTL Roomck - gross subroutine to see if the stack is about to colide with the top of the variable list ROOMCK: SSPD CHKSTK ;Put the stack pointer where we can read it LHLD CHKSTK ;Get the stack pointer into hl LDED VAREND ;Get the end of variables XRA A ;Clear ac and carry DSBC DE ;Subtract them CMP H ;See if h is zero JRZ ROOMC0 ;Yes -- getting close RM ;Return if more space EROUT: ERROR .BYTE OUTMEM ;Out of memory space ROOMC0: MOV A,L ;Get low half CPI 64 ;See if 64 words left RP ;Return if so JMPR EROUT ;Otherwise -- error .SBTTL Command dispatch tables COMTAB: .BYTE 'S ;Set command .BYTE 'I ;If command .BYTE 'D ;Do command .BYTE 'O ;On command .BYTE 'G ;Goto command .BYTE 'F ;For command .BYTE 'R ;Return command .BYTE 'T ;Type command .BYTE 'A ;Ask command .BYTE 'C ;Comment .BYTE 'E ;Erase command .BYTE 'W ;Write command .BYTE 'M ;Modify .BYTE 'Q ;Quit .IFNZ FTDEBG .BYTE 'H ;Call hdt .ENDC COMLEN=.-COMTAB COMDSP: .ADDR SETCOM ;Dispatch for set .ADDR IFCOM .ADDR DO .ADDR ON .ADDR GOTO .ADDR FOR .ADDR RETURN .ADDR TYPE .ADDR ASK .ADDR COMMNT .ADDR ERASE .ADDR WRITE .ADDR MODIFY .IFZ FTDEBG DSPEND: .ENDC .ADDR QUIT .IFNZ FTDEBG DSPEND: .ADDR CALHDT ;Call hdt CALHDT: TRAP ;Go do an hdt breakpoint JMP START ;Restart on a proceed .ENDC .SBTTL Eval -- function dispatch routine (efun) EFUN: XRA A ;Clear a EFUNL: SLAR A ;Shift hash left STA PTMP2 ;Save for a min CALL GETC ;Get the next char CALL TTERMS ;See if a terminator JRZ EFNAME ;Yes -- have the whole name ANI @37 ;Mask off hi 3 bits ADD PTMPM2(X) ;Add into hash JMPR EFUNL ;Loop for all chars EFNAME: CPI '( ;See if we have an open paren JRZ EFUNC ;Yes -- skip error ERROR .BYTE PFERR ;Parentheses error in function EFUNC: LDA PTMP2 ;Get the hash back PUSH AF ;Save for later CALL EVALM1 ;Evaluate the first arg POP AF ;Get function hash back CALL FUNC ;Go do the function PJMP EPAR ;Go check close paren .SBTTL Eval -- evaluate an expression EVALM1: CALL GETC ;Get a char EVAL: CALL ROOMCK ;See if we have enough room CALL GTFP0 ;Go get a 0 in flac STA LASTOP ; init lastop ARGNXT: LDA LASTOP ;Get last operation PUSH AF ;Put it on the stack CALL TTERMS ;See if this char is a terminator JRZ ETERM1 ;Branch if it is CALL TESTN1 ;See if a digit JRNC ENUM ;Branch if it is CPI '. ;See if leading dp JRZ ENUM ;Yes -- it's a number CPI 'F ;See if a function JRZ EFUN ;Yes -- go dispatch CALL GETVAR ;Otherwise it is a variable OPNEXT: CALL TTERMS ;Go see if next non-space is a terminator JRNZ MISOPR ;Branch if not CPI '( ;Left paren? JRNZ OPNXT1 ;No -- we cant have one MISOPR: ERROR .BYTE OPRMIS ;Operator missing -- eval OPNXT1: MOV A,C ;Get byte count in a CPI 7 ;Is it a delimiter? JM OPNXT2 ;Branch if not MVI C,0 ;Yes, then the operation level is lowest OPNXT2: POP AF ;Restore operation level CMP C ;Is operation level < or = to last one? JM ESTACK ;Branch if no DOBOP: STA LASTOP ;Yes, then store CPI 0 ;Lowest level? RZ ;Return if so MOV THSOPX(X),C ;Save thisop CALL POPT ;Restore ftmp CALL EVBOP ;Go do the operation MOV C,THSOPX(X) ;Get thisop back JMPR OPNXT2 ;And go do more ESTACK: PUSH AF ;Save thisop MOV LSTOPX(X),C ;Ans update lastop to thisop CALL PUSHF ;Save flac CALL GETC ;Skip over operator JMPR ARGNXT ;Go pick up next arg ETERM1: CPI '( ;Left paren? JRNZ ETERM2 ;Skip this if not CALL EVALM1 ;Yes -- call eval EPAR: LDA CHAR ;Get the delimiter which ended this level PUSH AF ;Save it for a min CALL GETC ;Move past it POP AF ;Restore it CPI ') ;Close paren? JRZ OPNEXT ;Yes -- go pick up next operator EPMISS: ERROR .BYTE PMATCH ;Parentheses mismatch ETERM2: MOV A,C ;Get byte count in a CPI 7 ;Delimiter on right hand side? JP ETERM3 ;Branch if so CPI 3 ;Or unary operator? JP MISOPN ;No, then it can't be here ETERM3: LDA LASTOP ;Get lastop CPI 0 ;See if zero JRZ OPNXT1 ;Only allow if at lowest level MISOPN: ERROR .BYTE OPNMIS ;Operand missing ENUM: CALL FLIN ;Go get a number JMP OPNEXT ;And go look for an operator EVBOP: LDA LASTOP ;Get operation to perform CPI 1 ;Add? JZ FADD ;Yes CPI 2 ;Subtract? JZ FSUB ; ... CPI 3 ;Divide? JZ FDIV ; .. CPI 4 ;Multiply? JZ FMULT ; ... CPI 5 ;Exponentiation? JZ FPOWR ; ... ERROR .BYTE UNAOP ;Unimplemented arithmetic operation TTERMS: CALL SPNOR ;Punt spaces LXI HL,TRMTAB ;Get terminator table LXI BC,TRMAX ;Get number of terminators CCDR ;Search backwards RET ;Return ; ; ; terminator table ; ; TRMSTR: .BYTE ' ;Level 0 (space) .BYTE '+ ;Level 1 .BYTE '- ;Level 2 .BYTE '/ ;Level 3 .BYTE '* ;Level 4 .BYTE '^ ;Level 5 .BYTE '( ;Level 6 .BYTE ') ;Level 7 .BYTE ', ;Level 8 .BYTE '; ;level 9 .BYTE CR ;Level 10 .BYTE '= ;Level 11 TRMTAB: .BYTE '_ ;Level 12 TRMAX=.-TRMSTR ;Number of table items .SBTTL Eval -- dispatch to a function (func) FUNC: LXI BC,FUNNUM ;Get the number of functions LXI HL,FUNEND ;Get the address of the function hash table CCDR ;Search the table backwards JRNZ BADFUN ;If no match -- bad function name SLAR C ;Shift c left RALR B ;May happen if more than 128 functions LXI HL,FUNDSP ;Get addr of dispatch DAD BC ;Add in displacement MOV E,M ;Get the low order of dispatch INX HL ;Increment pointer MOV H,M ;Get hi order MOV L,E ;Setup jump PCHL ;Go to addr calculated BADFUN: ERROR .BYTE UNRFUN ;Unrecognizable function name .SBTTL Functions -- some functions FABS: BIT B7,FLACM1(X) ;Test the sign bit in flac CNZ FCOMPL ;Complement if negative RET ;Return ; ; finr -- make an integer (rounded) ; FINR: CALL FIXR ;Fix and round the number PJMP FLOAT ;Float and return FINT: CALL FIX ;Fix the result PJMP FLOAT ;Float it and return FOUT: CALL PUSHF ;Save the flac CALL FIXR ;Fix and round flac LDA FLCM4 ;Get lsb CALL PRINTC ;Print it PJMP FPOPJ ;Restore flac and return ; ; fchr -- get a character from the keyboard ; FCHR: CALL ZERFLC ;Zero the flac CALL READC ;Get a char CALL PRINTC ;Echo it STA FLCM4 ;Save as lsb of flac PJMP FLOAT ;Float it and return FIXR: CALL SWAP ;Move flac into ftmp CALL GTFP5 ;Get .5 CALL FADD ;Add it PJMP FIX ;Fix it and return ; ; fdtr -- convert degrees to radians ; .IFNZ FTEXFN FDTR: LXI HL,CDTR ;Get 3.1415926/180 CALL GETTMP ; into ftmp PJMP FMULT ;Multiply, then return ; ; fsind -- sine with arg in degrees ; FSIND: CALL FDTR ;Convert degrees to radians ;And pfall into fsin ; ; fsin -- sine routine ; FSIN: CALL SWAP ;Put arg in ftmp LXI HL,HPI ;Get pi/2 CALL GETVA0 ; into flac CALL FSUB ;Subtract pi/2 from arg PBR FCOS ;And go do cosine ; ; fcosd -- cosine with arg in degrees ; FCOSD: CALL FDTR ;Convert degrees to radians ;Pfall into fcos .SBTTL Functions -- fcos - cosine routine FCOS: CALL PUSHF ;Put the arg on the stack CALL GTFP1 ;Get an fp 1.0 LXI HL,PTMPX ;Point to ptmp CALL PUTVA0 ;Put it in ptmp LXI HL,STMPX ;Point to running sum CALL PUTVA0 ;Init to 1 FCOSL: CALL FCOMPL ;Complement the term CALL POPT ;Restore the running sum CALL PUSHT ;Put it back on the stack CALL FMULT ;Multiply it CALL POPT ;Get it again CALL PUSHT ; ... CALL FMULT ;Multiply it again CALL SWAP ;Make room in flac LXI HL,PTMPX ;Get y CALL GETVA0 ; into flac CALL FDIV ;Divide it into the term CALL PUSHF ;Save the result so far LXI HL,PTMPX ;Get y back CALL GETVA0 ; ... CALL SWAP ;Put it in ftmp CALL GTFP1 ;Get 1.0 CALL FADD ;Add one to y LXI HL,PTMPX ;And put it CALL PUTVA0 ;Back in ptmp CALL POPT ;Restore term CALL FDIV ;Divide it LXI HL,CTMPX ;Put it CALL PUTVA0 ; in ctmp CALL SWAP ;Make room in flac LXI HL,STMPX ;Get stmp (running sum) CALL GETVA0 ; into flac LDA FLCEXP ;Get the exponent SUB FTMPEX(X) ;Subtract that of term .IFZ FBYTES-4 CPI 23 ;See if large difference .ENDC .IFZ FBYTES-6 CPI 39 .ENDC JP FCOSDN ;Yes -- return CALL FADD ;Go add the term to the sum LXI HL,STMPX ;Point to stmp CALL PUTVA0 ;Put it in stmp LXI HL,PTMPX ;Point to ptmp CALL GETVA0 ;Get it CALL SWAP ;Make room in flac CALL GTFP1 ;Get a 1.0 CALL FADD ;Add it to ftmp LXI HL,PTMPX ;Point to ptmp CALL PUTVA0 ;Put it back LXI HL,CTMPX ;Point to term CALL GETVA0 ;Put it in flac JMPR FCOSL ;Loop until undeflow FCOSDN: POP HL ;Pop the arg POP HL ; ... .IFZ FBYTES-6 POP HL ; ... .ENDC RET ;And return .SBTTL Functions -- fatn - arc tangent ; ; fatn -- arctangent ; FATN: BIT B7,FLACM1(X) ;Test sign of arg JRZ FATN0 ;Positive -- skip this CALL FCOMPL ;Complement the arg CALL FATN0 ;Go call the rest of the routine PJMP FCOMPL ;Negate result and return FATN0: LDA FLCEXP ;Get the exponent CPI 1 ;See if lt 1 JM FATN1 ;Yes -- just continue CALL SWAP ;Temp put it in ftmp CALL GTFP1 ;Get a 1 in flac CALL SWAP ;Change it again CALL FDIV ;Make 1/arg CALL FATN1 ;Go get the arc tangent LXI HL,HPI ;Get pi/2 CALL GETTMP ; into ftmp PJMP FSUB ;Ftmp-flac then return FATN1: CALL PUSHF ;Save the flac CALL POPT ;Restore it into ftmp CALL PUSHT ;And put it on the stack again CALL FMULT ;Go multiply them CALL PUSHF ;Put it on the stack too LXI HL,CB3 ;Get const #b3 CALL GETTMP ;Get the variable CALL FADD ;Add to x^2 (x^2+b3) LXI HL,A3 ;Point to constant "a3" CALL GETTMP ; get it CALL FDIV ;Divide (a3/(x^2+b3)) LXI HL,CB2 ;Point to "b2" CALL GETTMP ;Get it into ftmp CALL FADD ; b2+a3/(x^2+b3) CALL POPT ;Get x^2 into ftmp CALL PUSHT ;Put it back on the stack CALL FADD ; x^2+b2+a3/(x^2+b3) LXI HL,A2 ;Point to a2 CALL GETTMP ;Get it into ftmp CALL FDIV ; a2/(x^2+b2+a3/(x^2+b3)) LXI HL,CB1 ;Point to b1 CALL GETTMP ;Put it in ftmp CALL FADD ; b1+a2/(x^2+b2+a3/(x^2+b3)) CALL POPT ;Restore x^2 CALL FADD ; x^2+b1+a2/(x^2+b2+a3/(x^2+b3)) LXI HL,A1 ;Point to a1 CALL GETTMP ;Put in ftmp CALL FDIV ; a1/(x^2+b1+a2/(x^2+b2+a3/(x^2+b3))) LXI HL,CB0 ;Point to b0 CALL GETTMP ;Get it CALL FADD ; b0+a1/(x^2+b1+a2/(x^2+b2+a3/(x^2+b3))) CALL POPT ;Restore x PJMP FMULT ; x*(b0+a1/(x^2+b1+a2/(x^2+b2+a3/(x^2+b3)))) then return .SBTTL Functions -- fsqt - square root function FSQT: CALL FABS ;Take the absolute value CALL CHKZER ;See if arg is zero RZ ;Yes -- zero is the square root CALL PUSHF ;Put the arg on the stack SRAR FLACEX(X) ;Make LXI HL,$624E ; half SHLD FLCM1 ; assed MVI FLACM3(X),$38 ; guess LXI HL,PTMPX ;Put x CALL PUTVA0 ; into ptmp FSQTL: CALL POPT ;Put arg in ftmp CALL PUSHT ;Put it back on the stack again CALL FDIV ;Divide it by guess LXI HL,CTMPX ;Put it in CALL PUTVA0 ; ctmp CALL SWAP ;Make room LXI HL,PTMPX ; for x CALL GETVA0 ;Get it CALL FSUB ;Make y-x LDA PTMPX ;Get exp from x SUB FLACEX(X) ;Subtract the difference .IFZ FBYTES-4 CPI 22 ;See if small enough .ENDC .IFZ FBYTES-6 CPI 38 .ENDC JP FSQTD ;Yes -- done LXI HL,PTMPX ;Point to x CALL GETVA0 ;Get it CALL SWAP ;Make room for y LXI HL,CTMPX ;And get it CALL GETVA0 ; ... CALL FADD ;Add them DCR FLACEX(X) ;And divide the result by 2 LXI HL,PTMPX ;Put it back CALL PUTVA0 ; in ptmp JMPR FSQTL ;And loop FSQTD: POP HL ;Clean up POP HL ; the stack .IFZ FBYTES-6 POP HL ; ... .ENDC LXI HL,PTMPX ;Point to the result PJMP GETVA0 ;Get it into flac and return .SBTTL Functions -- fexp - exponential routine FEXP: CALL PUSHF ;Save the arg CALL GTFP1 ;Get 1.0 into flac LXI HL,PTMPX ;Put it in ptmp CALL PUTVA0 ; ... LXI HL,CTMPX ;And into CALL PUTVA0 ; ctmp FEXPL: CALL POPT ;Restore x CALL PUSHT ;And put it back on the stack CALL FMULT ;Multiply it CALL SWAP ;Put resullt in ftmp LXI HL,CTMPX ;Get CALL GETVA0 ;Our integer CALL FDIV ;Divide it LDA PTMPX ;Get exponent of running sum SUB FLACEX(X) ;Subtract that of the term .IFZ FBYTES-4 CPI 23 ;See if too small .ENDC .IFZ FBYTES-6 CPI 39 .ENDC JP FSQTD ;Yes -- done CALL PUSHF ;Save flac LXI HL,PTMPX ;Get the running sum CALL GETTMP ;Get it into ftmp CALL FADD ;Add them LXI HL,PTMPX ;Put it CALL PUTVA0 ; back LXI HL,CTMPX ;Get the integer CALL GETTMP ;Into ftmp CALL GTFP1 ;Get 1.0 CALL FADD ;Add it to the integer LXI HL,CTMPX ;Put it back CALL PUTVA0 ; into ctmp CALL POPF ;Restore the term JMPR FEXPL ;Loop until done .ENDC .SBTTL Functions -- misc I/O routines ; ; fidv -- set input device ; FIDV: CALL FIXR ;Go fix the number LDA FLCM4 ;Get low order byte STA IDEV ;Make it current input device PJMP FLOAT ;Float and return ; ; fodv -- set output device ; FODV: CALL FIXR ;Fix the number LDA FLCM4 ;Get low part STA ODEV ;Make it current output device PJMP FLOAT ;Float and return ; ; fcon -- set new console device ; FCON: CALL FIXR ;Fix the argument LDA FLCM4 ;Get low part (0-255) CALL CONINI ;Intialize new console device PJMP FLOAT ;Float and return ;Routine to initialize the device whose number is in the 'a' ;Register as the console device. CONINI: STA CONDEV ;Make it new console STA IDEV ;Also make it current input device STA ODEV ;And current output device PUSH AF ;Save device number LXI HL,INIDSP ;Get base address of dispatch table CALL CDEVD1 ;Call device depdendent code to initialize POP AF ;Get device number back LXI HL,INODSP ;Get base addr of dispatch table PJMP CDEVD1 ;Initialize and return. ; ; fcur -- address the cursor (on a single device) ; FCUR: LDA CHAR ;Get the last character typed CPI ', ;See if it was a comma JRZ FCUR0 ;Branch if so EARG2M: ERROR .BYTE ARG2M ;Second argument missing FCUR0: CALL FIXR ;Get the row number LDA FLCM4 PUSH AF ;Save it CALL EVALM1 ;Move past comma, pick up next arg CALL FIXR LDA FLCM4 MOV D,A ;Move column (horiz position) into d reg POP AF MOV E,A ;Move row (vert position) into e reg CALL CONCUR ;Enter device depdent code PJMP FLOAT ;Return when done .SBTTL Functions -- flog - logarith functions .IFNZ FTEXFN FLOG: CALL FLOG2 ;Get log in base 2 LXI HL,LOG102 ;Get log10(2) CALL GETTMP ; into ftmp PJMP FMULT ;Multiply them to make it base 10 and return ; ; fln -- base e logarithm ; FLN: CALL FLOG2 ;Get base two log LXI HL,LOGE2 ;Get loge(2) CALL GETTMP ; into ftmp PJMP FMULT ;Make it base e and return .SBTTL Functions -- flog2 - find base 2 logarithm FLOG2: CALL PUSHF ;Go push flac LDA FLCEXP ;Get exponent INR A ;Increment it PUSH AF ;Save it for a min CALL ZERFLC ;Zero the flac POP AF ;Restore af STA FLCM1 ;Put it in msb of flac MVI FLACEX(X),$06 ;Put exp of 6 in CALL NORM ;Normalize it CALL POPT ;Restore the arg CALL PUSHF ;And put exp on the stack MVI FTMPEX(X),$FF ;Make the exp -1 LXI HL,HSQRT2 ;Get 1/2 sqrt(2) CALL GETVA0 ; into flac CALL FSUB ;B=m-1/sqrt(2) CALL PUSHF ;Save it LXI HL,SQRT2 ;Get sqrt(2) CALL GETTMP ; into ftmp CALL FADD ;A=b+sqrt(2) CALL POPT ;Restore b CALL FDIV ;Z=b/a CALL PUSHF ;Save the result CALL PUSHF ;Make a copy CALL POPT ; in ftmp CALL FMULT ;Make z^2 CALL PUSHF ;Save it too LXI HL,LOGC1 ;Get first const CALL GETTMP ; into ftmp CALL FMULT ;Make z^2*first const LXI HL,LOGC2 ;Get second const CALL GETTMP ; into ftmp CALL FADD ;Add it in CALL POPT ;Restore z^2 CALL FMULT ;Multiply it LXI HL,LOGC3 ;Get 3rd const CALL GETTMP ; into ftmp CALL FADD ;Add them CALL POPT ;Restore z CALL FMULT ;Multiply LXI HL,$80FE ;Get -1/4 SHLD FTMPX ; into LXI HL,0 ; ftmp SHLD FTMP2 ; ... .IFZ FBYTES-6 SHLD FTMP4 ; ... .ENDC CALL FADD ;Add -1/4 CALL POPT ;Restore exp PJMP FADD ;Add it in and return .ENDC ; ; gettmp ; .IFNZ FTEXFN!FTEXPF GETTMP: MOV A,M ;Get the first byte STA FTMPX ;Store the exponent INX HL ;Bump pointer MOV A,M ;Get the next byte STA FTMP1 ;Store it INX HL ;Bump pointer MOV A,M ;Get the third STA FTMP2 ; ... INX HL ;Bump to last byte MOV A,M ;Get it STA FTMP3 ;Store .IFZ FBYTES-6 INX HL ; get MOV A,M ; last STA FTMP4 ; two INX HL ; bytes MOV A,M ; ... STA FTMP5 ; ... .ENDC RET ;And return .ENDC ; ; fini -- initialize an input device ; FINI: LXI HL,INIDSP ;Point to proper dispatch table PBR FDEVD ;Call device dependent code and return ; ; fino -- initialize an output device ; FINO: LXI HL,INODSP ;Point to proper dispatch table PBR FDEVD ;Call device dependent code and return ; ; fcli -- close an input device ; FCLI: LXI HL,CLIDSP ;Point to proper dispatch table PBR FDEVD ;Call device dependent code and return ; ; fclo -- close an output device ; FCLO: LXI HL,CLODSP ;Point to proper dispatch table FDEVD: PUSH HL ;Save pointer to dispatch table CALL FIXR ;Integerize device number POP HL ;Get pointer back CALL CDEVD ;Call device depdendent code through table PJMP FLOAT ;Float and return ; ; fech -- set or unset the terminal echoing ; FECH: LDA FLCM1 ;Get the hi byte CPI 0 ;See if zero JRZ FECH1 ;Skip if so MVI A,$FF ;No -- make all ones FECH1: STA ECHFLG ;Set it in echo flag RET ;And return ;Routines to call device depdendent I/O routines. ;"call cdevd1" if device number is in the 'a' register and no ;Parameters need to be passed. ;"call cdevd2" with device number in the 'c' register and parameters ;In 'a', 'd', or 'e' registers. CDEVD: LDA FLCM4 ;Get device number from floating ac CDEVD1: MOV C,A ;Get device number into c reg CDEVD2: SLAR C ;Device number times two = table offset MVI B,0 ;Zero into high order bc DAD BC ;Add to base addr MOV C,M ;Get low order addr to go to INX HL ;Point to high order MOV H,M ;Get high order MOV L,C ;Now low order SHLD IOTEMP ;Save as addr of routine CALL CALLIN ;Now call device depdendent code JRNC NOIOER ;Branch if no I/O error LDA CONDEV ;Error! reset I/O devices to console STA IDEV STA ODEV ;So error message is visable ERROR ;Trap .BYTE IOERR ;? device I/O error NOIOER: RET ;Return .SBTTL Functions -- function dispatch tables FUNTAB: .BYTE $36 ;Fabs .BYTE $F4 ;Fout .BYTE $BC ;Fitr .BYTE $A4 ;Finr .IFNZ FTEXFN .BYTE $04 ;Fsqt .BYTE $7A ;Fcos .BYTE $FC ;Fcosd .BYTE $D8 ;Fsin .BYTE $B8 ;Fsind .BYTE $74 ;Fatn .BYTE $A8 ;Fexp .ENDC .BYTE $70 ;Fcon -- set new console device .BYTE $90 ;Fcur -- address the cursor .BYTE $84 ;Fidv -- set input device .BYTE $B4 ;Fodv -- set the output device .IFNZ FTEXFN .BYTE $AA ;Flog .BYTE $4C ;Fln .ENDC .BYTE $44 ;Fech .BYTE $92 ;Fini .BYTE $9E ;Fino .BYTE $5A ;Fcli .BYTE $66 ;Fclo .IFNZ FTEXFN .BYTE $94 ;Fdtr .ENDC FUNEND: .BYTE $5C ;Fchr FUNNUM=.-FUNTAB ; ;Some space for hackers ; .BYTE 0 .BYTE 0 .BYTE 0 .BYTE 0 .BYTE 0 FUNDSP: .ADDR FABS .ADDR FOUT .ADDR FINT .ADDR FINR .IFNZ FTEXFN .ADDR FSQT .ADDR FCOS .ADDR FCOSD .ADDR FSIN .ADDR FSIND .ADDR FATN .ADDR FEXP .ENDC .ADDR FCON .ADDR FCUR .ADDR FIDV .ADDR FODV .IFNZ FTEXFN .ADDR FLOG .ADDR FLN .ENDC .ADDR FECH .ADDR FINI .ADDR FINO .ADDR FCLI .ADDR FCLO .IFNZ FTEXFN .ADDR FDTR .ENDC .ADDR FCHR ; ;Some space for hackers ; .ADDR 0 .ADDR 0 .ADDR 0 .ADDR 0 .ADDR 0 .SBTTL Getvar - get a variable from the variable list ; otherwise, create it and assign it a value of zero ; ; GTERR3: ERROR .BYTE FUNILL ;Function illegal GETVAR: CALL SPNOR ;Ignore spaces CPI 'A ;Is it alphabetic? JM VARBAD ;No -- punt CPI @133 ;Ascii z + 1 JM VAROK ;Branch if alpha VARBAD: ERROR .BYTE BADVAR ;Bad variable name VAROK: CPI 'F ;Function name? JRZ GTERR3 ;Yes -- to bad SLAR A ;Yes -- shift it left SLAR A ;To make room SLAR A ;For a digit PUSH AF ;Save it for a while CALL GETC ;Get a char XRI $30 ;See if octal CPI 8 ; ... JP VARDUN ;If not, done with name POP BC ;Get other half back ORA B ;Or them together PUSH AF ;And put it back on the stack CALL GETC ;And get another char VARDUN: CALL SPNOR ;Go ignore spaces CPI '( ;Left paren? JRZ VARSUB ;Yes -- it has a subscript LXI HL,0 ;Otherwise get a zero JMPR VARSOK ;And process it VARSUB: CALL EVALM1 ;Go get the subscript CALL FIXR ;And fix it LDA CHAR ;Get the terminator CPI ') ;Close paren? JNZ EPMISS ;No -- too bad CALL GETC ;Get another char LHLD FLCM3 ;Get subscript VARSOK: SHLD VSUB ;Save it for later POP AF ;Get the name back STA VCHAR ;Save it CALL VARINI ;Init the variable pointers CHKVAR: MOV A,M ;Get the variable name CPI EOV ;End of variables? JRZ NOVAR ;Branch if so CMP VCHARX(X) ;Same name? JRZ CHKSUB ;Yes -- go check subscript NOTVAR: CALL NXTVAR ;Go point to next variable JMPR CHKVAR ;And go check it CHKSUB: LDA VSUB ;Get the required subscript INX HL ;Bump pointer CMP M ;See if we have a match JRNZ NOTVAR ;No -- try next LDA VSUB+1 ;Get second half of subscript INX HL ;Bump pointer CMP M ;See if another match JRNZ NOTVAR ;No -- try next variable LOCVAR: PJMP FETVAR ;Get the variable's value into flac NOVAR: LDA VCHAR ;Get the variable's name MOV M,A ;Put it in memory INX HL ;Bump pointer LDA VSUB ;Get the subscript MOV M,A ;Store it INX HL ;Bump pointer LDA VSUB+1 ;Get second half of subscript MOV M,A ;Store it INX HL ;Bump pointer CALL GTFP0 ;Zero flac CALL PUTVAR ;Put zero into the variable INX HL ;Point to next loc MVI M,EOV ;Flag end of variable list SHLD VAREND ;Say end of variable list PJMP ROOMCK ;Check the stack and return (value already in flac) NXTVAR: LHLD VARADR ;Get the current variable address LXI BC,FBYTES+3 ;7 bytes/variable DAD BC ;Add it in SHLD VARADR ;Save new address RET ;And return .SBTTL Fpowr - raise ftmp to the integer power in flac FPOWR: CALL PUSHT ;Save the number for a min CALL FIXR ;Convert the power to fixed point CALL POPT ;Restore ftmp FPOWR1: MOV H,FLACM3(X) ;Get 16 bit MOV L,FLACM4(X) ; power CALL GTFP1 ;Get a floating point 1 in flac BIT B7,H ;Negative power? JRNZ NPOWR ;Yes -- go do it POWRLP: MVI A,$FF ;Put -1 in a DCX HL ;Decrement power counter CMP H ;See if negative yet RZ ;Return if so PUSH HL ;Save the count CALL PUSHT ;Push ftmp CALL FMULT ;Multiply them CALL POPT ;Restore ftmp POP HL ;Restore the count JMPR POWRLP ;And loop until done ; ; here to raise a number to a negative power ; NPOWR: XRA A ;Zero a CMP H ;See if zero yet RZ ;Return if so INX HL ;Increment the count PUSH HL ;Save the count for now CALL PUSHT ;Save x CALL SWAP ;Make 1/x^n CALL FDIV ;Do the divide CALL POPT ;Restore x POP HL ;And the count JMPR NPOWR ;Loop until done .SBTTL Software ac push/pop routines ; ; pusht -- push ftmp on the stack ; PUSHT: LHLD FTMPX ;Get the first 16 bits XTHL ;Swap with return address LDED FTMP2 ;Get the rest PUSH DE ;Push it .IFZ FBYTES-6 LDED FTMP4 ;Get the low part PUSH DE ;Push it .ENDC PCHL ;And return ; ; popt -- restore ftmp ; POPT: POP HL ;Restore return addr POP DE ;Restore low half .IFZ FBYTES-6 SDED FTMP4 ;Store it POP DE ;Get middle .ENDC SDED FTMP2 ;Store it POP DE ;Restore hi half SDED FTMPX ;Store it PCHL ;And return ; ; pushf -- push flac on the stack ; PUSHF: LHLD FLCEXP ;Get first half of flac XTHL ;Put it on top of the stack LDED FLCM2 ;Get second half PUSH DE ;Put it on the stack .IFZ FBYTES-6 LDED FLCM4 ;Get low part PUSH DE ;Save it .ENDC PCHL ;And return ; ; popf -- restore flac ; POPF: POP HL ;Restore hl POP DE ;Get first part of flac .IFZ FBYTES-6 SDED FLCM4 ;Store it POP DE ;Get middle part .ENDC SDED FLCM2 ;Store it POP DE ;Pop second half SDED FLCEXP ;Store it PCHL ;And return .SBTTL Math package ; ; ; ; *** floating point routines for the Z80 cpu *** ; ; these floating point routines are designed to be used ; with FOCAL for the Z80. the basic functions are: ; fadd: add the number in ftmp to flac ; fsub: subtract the number in flac from ftmp ; fmult: multiply the number in flac by ftmp ; fdiv: divide the number in ftmp by flac ; in all cases, the result is returned in flac. ; the following I/O routines are also implemented: ; flin: input a floating point number into flac ; flout: output a floating point number according ; to the format given in format. ; ; ; some basic routines ; ; ADD3: LXI Y,XBLOCK ;Setup the offset in the y reg MVI B,FBYTES-1 ;Three bytes ORA A ;Clear carry ADD1: MOV A,FLACEX+FBYTES-1(Y) ;Get the first byte ADC FTMPEX+FBYTES-1(Y) ;Add in the other byte MOV FLACEX+FBYTES-1(Y),A ;Store the result DCX Y ;Decrement the memory pointer DJNZ ADD1 ;Loop until done RET ;And return MD1: SLAR SIGNX(X) ;Shift sign left CALL ABSWAP ;Abs val m1, then swap ABSWAP: BIT B7,FLACM1(X) ;Flac negative? JRZ ABSWP1 ;No -- just swap CALL FCOMPL ;Yes -- negate it INR SIGNX(X) ;Complement sign ABSWP1: STC ;Set carry for mult/div ; ; fexch -- exchange flac and ftmp ; SWAP: MVI B,FBYTES ;Setup for a 4 byte move LXI Y,XBLOCK+FBYTES-1 ;Set pointer to memory SWAP1: MOV FLACEX+FBYTES(Y),C ;Store a byte (convoluto) MOV A,FLACEX(Y) ;Get a byte MOV C,FTMPEX(Y) ; from both ac's MOV FLACEX(Y),C ;Store them MOV FTMPEX(Y),A ; exchanged DCX Y ;Decrement memory pointer DJNZ SWAP1 ;And loop for 4 bytes RET ;And return ; ; float a 32 bit integer in flacm1-m2 ; FLOAT: MVI A,$1E ;Const STA FLCEXP ;Set exponent to 30 .IFZ FBYTES-6 XRA A ;Get a zero STA FLCM5 ;Zero lsb of number .ENDC PBR NORM ;Go normalize it NORM1: DCR FLACEX(X) ;Decrement the exponent .IFZ FBYTES-4 SLAR FLACM4(X) ;Shift left one place .ENDC .IFZ FBYTES-6 SLAR FLACM5(X) ;Shift left one place RALR FLACM4(X) ; ... .ENDC RALR FLACM3(X) ; ... RALR FLACM2(X) ; ... RALR FLACM1(X) ; ... NORM: LDA FLCM1 ;Get hi byte SLAR A ;Test to see if 2 hi XRA FLACM1(X) ; bits are the same RM ;Yes -- return LDA FLCEXP ;Get exponent CPI $80 ;Zero ? JRNZ NORM1 ;No -- shift RET ;Yes -- just return ; ; ftmp-flac into flac ; FSUB: CALL FCOMPL ;Negate flac SWPALG: CALL ALGNSW ;Right shift m1 or swap on carry ; ; ftmp+flac into flac ; .IFZ FBYTES-4 FADD: MVI FLACM4(X),0 ;So norm doesn't mess us up .ENDC .IFZ FBYTES-6 FADD: .ENDC LDA FLCEXP ;Get flac's exponent CMP FTMPEX(X) ;Compare it to ftmp JPE FADD1 ;If overflow -- just return larger number JRNZ SWPALG ;If not -- swap or align CALL ADD3 ;Add mantissas ADDEND: JPE RTLOG ;Shift right if overflow CALL NORM ;Go normalize the result BIT B7,FLACEX+FBYTES(X);Test the super lsb RZ ;Just return if off SET B0,FLACEX+FBYTES-1(X) ;Trivial attempt at rounding RET ;Return FADD1: BIT B7,FLACEX(X) ;See which one is a positive exponent PJRZ NORM ;Flac -- just normalize and return PBR SWAP ;Ftmp -- swap and return ; swap if carry clear, else shift right ALGNSW: JP SWAP ;Swap if not in right order RTAR: LDA FLCM1 ;Get hi byte of flac SLAR A ;Put hi byte in carry JMPR RTL1 ;To simulate sraix RTLOG: BIT B7,FLACM1(X) ;Test the hi bit in flac JRZ RTL0 ;Branch if zero ORA A ;Clear the carry JMPR RTL1 ;And skip this RTL0: STC ;Set the carry flag RTL1: INR FLACEX(X) ;Compensate for the shift JPE OVFL ;Jump if overflow RTLOG1: RARR FLACM1(X) ;Shift in the new sign MVI B,FBYTES+FBYTES-3 ;Setup loop counter for 5 bytes LXI Y,XBLOCK ;Setup index register RTLOG2: RARR FLACM2(Y) ; shift the byte right INX Y ;Increment the pointer DJNZ RTLOG2 ;And loop for 5 bytes RET ;Return ; ; flac*ftmp into flac ; FMULT: CALL MD1 ;Abs value of m1, m2 ADC FLACEX(X) ;Add the exponents CALL MD2 ;Check and prep for mult ORA A ;Clear carry MUL1: EXX ;Temporarily save b CALL RTLOG1 ;Shift prod and multiplier right JRNC MUL2 ;Shift partial prod CALL ADD3 ;Add in multiplicand MUL2: EXX ;Get iteration coutn back DCR B ;Decrement iteration counter JP MUL1 ;Loop until done MDEND: SRAR SIGNX(X) ;Sign even or odd? NORMX: JNC NORM ;If even, normalize, else complement FCOMPL: .IFZ FBYTES-4 XRA A ;Clear carry flag and a STA FLCM4 ;So norm doesn't mess us up .ENDC MVI B,FBYTES-1 ;Three bytes LXI HL,FLCEXP+FBYTES-1 COMPL1: MVI A,0 ;Zero a without affecting carry SBB M ;Subtract MOV M,A ;And store DCX HL ;Bump index DJNZ COMPL1 ;Loop until done JMPR ADDEND ;Fix up and return ; ;Divide ftmp by flac giving flac ; FDIV: CALL MD1 ;Abs value m1,m2 SUB FLACEX(X) ;Subtract exponents CALL MD2 ;Save as res exponent DIV1: .IFZ FBYTES-6 LDA FTMP5 ;Get low byte SUB FLACMA(X) ;Subtract PUSH AF ;Save result LDA FTMP4 ;Get next byte SBB FLACM9(X) ;Subtract PUSH AF ;Save result LDA FTMP3 ;Get middle byte SBB FLACM8(X) ;Subtract PUSH AF ; ... LDA FTMP2 ; ... SBB FLACM7(X) ; ... PUSH AF ; ... LDA FTMP1 ; ... SBB FLACM6(X) ; ... .ENDC .IFZ FBYTES-4 LDA FTMP3 ;Get low byte SUB FLACM6(X) ;Subtract PUSH AF ;Save result LDA FTMP2 ;Get middle byte SBB FLACM5(X) ;Subtract it PUSH AF ;Save it LDA FTMP1 ;Get hi byte SBB FLACM4(X) ;Subtract .ENDC JRC DIV2 ;If ftmp&$FF ;Get low part of sten table addr CMP E ;See if at end of table JRZ PRTUNI ;Yes -- go print units SDED JOKAD1 ;No -- rejock LDED JOKAD0 ;Get other jocked address DCX DE ;And DCX DE ; rejock SDED JOKAD0 ; it too JMPR NOUT0 ;And go finish the print PRTUNI: EXX ;Point to other regs MOV A,LP ;Get last digit back ADI @060 ;Make it ascii CALL PRINTC ;Print it INR NUMDGX(X) ;Increment number of digits output RET ;Hope he didn't care which reg set we used .SBTTL Constant storage -- 4 or 6 byte storage macro .IFZ FBYTES-6 .MACR FCONST AA,BB,CC,DD,EE,FF .BYTE AA .BYTE BB .BYTE CC .BYTE DD .BYTE EE .BYTE FF .ENDM .ENDC .IFZ FBYTES-4 .MACR FCONST AA,BB,CC,DD,EE,FF .BYTE AA .BYTE BB .BYTE CC .BYTE DD .ENDM .ENDC .SBTTL Constant storage -- power of ten tables STEN: .ADDR $0001 ;10^0 (low half in this table) .ADDR $000A ;10^1 .ADDR $0064 ;10^2 .ADDR $03E8 ;10^3 .ADDR $2710 ;10^4 .ADDR $86A0 ;10^5 .ADDR $4240 ;10^6 .ADDR $9680 ;10^7 .ADDR $E100 ;10^8 STNEN0: .ADDR $CA00 ;10^9 STEN1: .ADDR $0000 ;10^0 (hi half) .ADDR $0000 ;10^1 .ADDR $0000 ;10^2 .ADDR $0000 ;10^3 .ADDR $0000 ;10^4 .ADDR $0001 ;10^5 .ADDR $000F ;10^6 .ADDR $0098 ;10^7 .ADDR $05F5 ;10^8 STNEN1: .ADDR $3B9A ;10^9 .SBTTL Constant storage -- floating point powers of ten FSTEN: FCONST $00,$40,$00,$00,$00,$00 ;10^0 FCONST $03,$50,$00,$00,$00,$00 ;10^1 FCONST $06,$64,$00,$00,$00,$00 ;10^2 FCONST $09,$7D,$00,$00,$00,$00 ;10^3 FCONST $0D,$4E,$20,$00,$00,$00 ;10^4 FCONST $10,$61,$A8,$00,$00,$00 ;10^5 FCONST $13,$7A,$12,$00,$00,$00 ;10^6 FCONST $17,$4C,$4B,$40,$00,$00 ;10^7 FCONST $1A,$5F,$5E,$10,$00,$00 ;10^8 FCONST $1D,$77,$35,$94,$00,$00 ;10^9 FCONST $21,$4A,$81,$7C,$80,$00 ;10^10 .SBTTL Constant storage -- some useful constans for the functions .IFNZ FTEXFN ;Constants for atan A1: FCONST $01,$76,$B2,$3A,$2F,$25 A2: FCONST $02,$8E,$4A,$B5,$F9,$4C A3: FCONST $FE,$BC,$38,$1F,$AC,$18 CB0: FCONST $FD,$59,$6C,$70,$0D,$24 CB1: FCONST $02,$6C,$31,$B8,$EA,$6D CB2: FCONST $01,$6A,$1F,$6B,$7A,$CD CB3: FCONST $00,$5C,$B6,$61,$10,$10 ; ; constants for sin/cos ; CDTR: FCONST $FA,$47,$7D,$1A,$8E,$CA HPI: FCONST $00,$64,$87,$ED,$58,$CD ;3.1415926/2 ; ; constants for flog ; LOG102: FCONST $FE,$4D,$10,$4D,$42,$7D ;Log10(2) LOGE2: FCONST $FF,$58,$B9,$0B,$FB,$E6 ;Loge(2) HSQRT2: FCONST $FF,$5A,$82,$79,$99,$FC ;Sqrt(2)/2 SQRT2: FCONST $00,$5A,$82,$79,$99,$FC ;Sqrt(2) LOGC1: FCONST $FF,$4C,$AB,$55,$18,$60 ;Constants LOGC2: FCONST $FF,$7B,$11,$78,$3C,$40 LOGC3: FCONST $01,$5C,$55,$20,$1D,$57 .ENDC .SBTTL Flin - floating point input routine FLIN: CALL NIN ;Go get an integer CALL FLOAT ;Float it LDA CHAR ;Get the terminator CPI '. ;Decimal point? .IFNZ FTEXPF JRNZ FLIN0 ;No -- check for enn .ENDC .IFZ FTEXPF RNZ ;No -- return .ENDC CALL PUSHF ;Go push flac CALL GETC ;Get a char CALL NIN ;Go input a number CALL FLOAT ;Float it MOV C,NUMDGX(X) ;Get the number of digits typed CALL GSTEN ;Get the power of ten into ftmp CALL SWAP ;Go swap the order CALL FDIV ;Divide number typed by the power of ten CALL POPT ;Restore ftmp .IFZ FTEXPF PJMP FADD ;Add them and return .ENDC .IFNZ FTEXPF CALL FADD ;Add them together LDA CHAR ;Get the terminator back FLIN0: CPI 'E ;Did he give a power of ten? RNZ ;Return if not RES B7,PTMPM1(X) ;Clear negative exp flag CALL GETC ;Get the next character CALL TESTN ;See if a digit JRNC FLIN1 ;Assume positive exp if so CPI '+ ;See if plus JRZ FLIN2 ;Yes -- go do the right thing CPI '- ;Minus? JRNZ FLIN1 ;No -- must have typed garbage SET B7,PTMPM1(X) ;No -- flag negative exp FLIN2: CALL GETC ;Eat over the sign bit FLIN1: CALL PUSHF ;Save flac CALL NIN ;Get the power of ten BIT B7,PTMPM1(X) ;See if negative JRZ FLIN3 ;No -- skip this XRA A ;Clear a SUB FLACM4(X) ;Subtract low byte STA FLCM4 ;Store it MVI A,0 ;Get zero in a SBB FLACM3(X) ;Subtract the other byte STA FLCM3 ;Store it FLIN3: LXI HL,FSTEN+FBYTES ;Point to 10 CALL GETTMP ;Get it CALL FPOWR1 ;Make 10^n CALL POPT ;Restore the number PJMP FMULT ;Multiply and return .ENDC .SBTTL Flout -- output the floating point number in flac FLOUT: MVI A,@040 ;Get a space for the default sign BIT B7,FLACM1(X) ;See if flac is negative JRZ FLOUT0 ;Skip if not CALL FCOMPL ;Yes -- complement the flac MVI A,'- ;And get the proper sign FLOUT0: CALL PRINTC ;Print the sign .IFNZ FTEXPF MVI C,9 ;Get 10^9 CALL FCMP ;See if flac ge 10^9 JZ EXPOUT ;Yes -- print it in exp format LDA MANDIG ;Get number of digits for integer part CPI 0 ;See if zero JRZ EXPOUT ;Yes -- go print in exp format .ENDC CALL PUSHF ;Save the flac CALL GTFP5 ;Get a floating .5 MOV C,NFRACX(X) ;Get the number of digits for the fraction CALL GSTEN ;Get the proper power of 10 CALL SWAP ;Swap flac and ftmp CALL FDIV ;Make .5/10^nfrac CALL POPT ;Restore ftmp CALL FADD ;Add in rounding factor CALL PUSHF ;Put new flac on the stack CALL FIX ;Fix the number MVI A,11 ;Make SUB MDIGX(X) ; the number of digits to type MOV B,A ;Put it in b MVI C,@040 ;Use spaces for leading zeros CALL NOUT ;Print the number CALL FLOAT ;Re-float it CALL POPT ;Restore ftmp CALL FSUB ;Subtract integer from full number LDA NUMDIG ;Get the number of digits typed CPI 7 ;See if ge 7 JM FLOUT1 ;No -- skip this CALL ZERFLC ;Yes -- zero the flac FLOUT1: XRA A ;Get a zero in a CMP NFRACX(X) ;See if no digits in fraction RZ ;Yes -- just return now MVI A,'. ;No -- get a dp CALL PRINTC ;Print it MOV C,NFRACX(X) ;Get number of digits again CALL GSTEN ;Get the power of ten CALL FMULT ;Multiply it by the fraction CALL FIX ;And fix the result MVI A,10 ;Max of 10 zeros to suppress SUB NFRACX(X) ;Subtract off number to type MOV B,A ;Put in b MVI C,'0 ;Use zero for lz PJMP NOUT ;Output the number and return .SBTTL Flout -- expout - print the number in exponential format ; ; -.mmmmmme-pp ;always 12 characters long ; ; called when the number of digits specified for output = 0 ; or when flac > 2^26 ; ; .IFNZ FTEXPF EXPOUT: RES B7,PTMPM1(X) ;Set havent rounded flag MVI PTMPEX(X),0 ;Put zero in power of ten MVI A,'. ;Get a dp CALL PRINTC ;Print it CALL CHKZER ;See if flac is zero JRZ EXPOU3 ;Special case if so .IFZ FBYTES-4 MVI A,6 ;Assume positive exponent of 10^6 .ENDC .IFZ FBYTES-6 MVI A,9 ;Assume positive exponent of 10^9 .ENDC STA PTMPX ;Save exponent .IFZ FBYTES-4 EXPOU5: MVI C,5 ;Get 10^5 .ENDC .IFZ FBYTES-6 EXPOU5: MVI C,8 ;Get 10^8 .ENDC CALL FCMP ;Go compare the numbers JRNZ EXPOU1 ;If less than, go scale upwards .IFZ FBYTES-4 MVI C,6 ;Get 10^6 .ENDC .IFZ FBYTES-6 MVI C,9 ;Get 10^9 .ENDC CALL FCMP ;Compare to flac JRZ EXPOU2 ;Jump if we need to scale down BIT B7,PTMPM1(X) ;See if we have rounded yet JRNZ EXPOU3 ;Yes -- go print it now CALL SWAP ;Swap flac and ftmp CALL GTFP5 ;Get a floating .5 CALL FADD ;Add it to flac SET B7,PTMPM1(X) ;Set the rounded flag JMPR EXPOU5 ;May have to rescale EXPOU3: CALL FIX ;Go fix the number .IFZ FBYTES-4 MVI B,4 ;Suppress four zeros .ENDC .IFZ FBYTES-6 MVI B,1 ;Suppres 1 zero .ENDC MVI C,'0 ;Leading zero char CALL NOUT ;Go print the number MVI A,'E ;Get exponent char CALL PRINTC ;Print it MVI A,'+ ;Assume positive exp BIT B7,PTMPEX(X) ;Test the exponent's sign JRZ EXPOU4 ;Positive -- skip this LDA PTMPX ;Get exponent NEG ;Negate it STA PTMPX ;Store it MVI A,'- ;Get minus sign EXPOU4: CALL PRINTC ;Print sign CALL ZERFLC ;Zero flac LDA PTMPX ;Get exponent STA FLCM4 ;Store it in low part of flac MVI B,8 ;Suppress 8 zeros MVI C,'0 ;Leading zero PJMP NOUT ;Go print it EXPOU1: MVI C,1 ;Get 10^1 CALL GSTEN ;Get 10^1 into ftmp CALL FMULT ;Multiply flac by 10 DCR PTMPEX(X) ;Decrement exponent JMPR EXPOU5 ;And go recompare EXPOU2: MVI C,1 ;Get a 1 CALL GSTEN ;Get 10^1 into ftmp CALL SWAP ;And swap them CALL FDIV ;Go divide by 10 INR PTMPEX(X) ;Increment exponent JMPR EXPOU5 ;Go test again FCMP: CALL PUSHF ;Push the flac CALL GSTEN ;Get the power of ten to compare CALL SWAP ;Exchange them CALL FSUB ;Subtract them BIT B7,FLACM1(X) ;Test the sign of the result .ENDC FPOPJ: POP HL ;Restore .IFZ FBYTES-6 SHLD FLCM4 ; POP HL ; .ENDC SHLD FLCM2 ; the POP HL ; flac SHLD FLCEXP ; ... RET ;And return .SBTTL Misc utility routines ZERFLC: MVI A,0 ;Zero a (don't play with flags) STA FLCEXP ;And STA FLCM1 ; zero STA FLCM2 ; all STA FLCM3 ; the STA FLCM4 ; bytes in flac .IFZ FBYTES-6 STA FLCM5 ; ... .ENDC RET ;Then return GTFP5: CALL ZERFLC ;Zero the flac DCR A ;Put ff in a STA FLCEXP ;Put in the exponent PBR GTFP1N ;And continue in gtfp1 ; ; get a floating point 1 ; GTFP1: CALL ZERFLC ;Zero the flac GTFP1N: MVI FLACM1(X),$40 ;Put a 1 in flacm1 RET ;And return ; ; get a floating point zero (exp of $80) ; GTFP0: CALL ZERFLC ;Zero the flac SET B7,FLACEX(X) ;Set hi order bit RET ;And return ; ; check flac for zero ; CHKZER: LDA FLCM1 ;Get first byte of flac ORA FLACM2(X) ; or in the rest ORA FLACM3(X) ; of flac .IFZ FBYTES-6 ORA FLACM4(X) ; ... ORA FLACM5(X) ; ... .ENDC RET ;Return ; ; gsten -- get a floating point power of ten from fsten table ; into ftmp. enter with power of ten in c ; GSTEN: MVI B,0 ;Zero hi half of bc LXI Y,FSTEN ;Get addr of floating sten .IFZ FBYTES-6 MOV A,C ;Put the power in a PUSH AF ;Save a .ENDC SLAR C ;Multiply c .IFZ FBYTES-6 POP AF ;Restore a ADD C ;Add in power*2 MOV C,A ;Put in c .ENDC SLAR C ; by 4 DADY BC ;Add into base address MOV A,0(Y) ;Get the first byte STA FTMPX ;Store the exponent MOV A,1(Y) ;And get the STA FTMP1 ; mantissa MOV A,2(Y) ; ... STA FTMP2 ; ... MOV A,3(Y) ; ... STA FTMP3 ; ... .IFZ FBYTES-6 MOV A,4(Y) ; ... STA FTMP4 ; ... MOV A,5(Y) ; ... STA FTMP5 ; ... .ENDC RET ;Return .SBTTL Intout - print a signed 32 bit integer INTOUT: MVI B,10 ;Max number of zeros to suppress MVI C,@040 ;Use spaces for leading zeros BIT B7,FLACM1(X) ;Test sign bit on hi order JZ NOUT ;If positive, no jocking needed PUSH BC ;Save b and c MVI A,'- ;Get minus sign CALL PRINTC ORA A ;Clear the carry MVI B,4 ;4 bytes LXI HL,FLCM4 ;Address of flac INTOU0: MVI A,0 ;Get a zero (don't mess with carry) SBB M ;Form complement MOV M,A ;Put result in memory DCX HL ;Decrement memory pointer DJNZ INTOU0 ;Loop for 4 bytes POP BC ;Restore bc PJMP NOUT ;Type the number and return .SBTTL Data storage PRGEND: .ADDR PRGINI ;Beginning of program .IFNZ FTINDX IDXBEG: .ADDR PRGINI+1 ;Beginning of index IDXEND: .ADDR INIVAR-1 ;End of index .ENDC VARBEG: .ADDR INIVAR ;Beginning of variables VAREND: .ADDR INIVAR ;End of variables CHKSTK: .ADDR 0 ;Used by roomck ;I/O related locs CONDEV: .BYTE 0 ;Device number of user's console IDEV: .BYTE 0 ;Holds device number of current input device ODEV: .BYTE 0 ;Holds device number of current output device CALLIN: .BYTE $C3 ;Opcode for 'jmp' instruction IOTEMP: .ADDR 0 ;Holds temporaries for I/O related operations ;End of I/O related locs XBLOCK=. ;X register start addr Z=0 ;Temp counter ; ; some storage macros ; .MACR BLOCKB XXXXX,XXXXXX XXXXX: .BYTE 0 XXXXXX=Z Z=Z+1 .ENDM .MACR BLOCKW XXXXX,XXXXXX XXXXX: .ADDR 0 XXXXXX=Z Z=Z+2 .ENDM .MACR BLOCKV XXXXX,XXXXXX,ZZZZZZ XXXXX: .BYTE ZZZZZZ XXXXXX=Z Z=Z+1 .ENDM BLOCKW PC,PCX BLOCKW TXTADR,TXTARX ;Text pointer BLOCKB LINENO,LINNOX ;Current line number BLOCKB GRPNO,GRPNOX ;Current group number BLOCKB CHAR,CHARX ;Current character BLOCKW TXTAD2,TXTA2X ; ... BLOCKW VARADR,VARARX ;Variable pointer BLOCKB DMPSW,DMPSWX ;Trace flag BLOCKB DEBGSW,DBGSWX ;Trace enable BLOCKB ECHFLG,EFLGX ;Of non-zero, will turn the echo off BLOCKB INSW,INSWX ;Says text comes from memory BLOCKB IFONSW,INONSX ;Says if or on BLOCKB MSCHAR,MSCHRX ;Place to save search char for modify BLOCKB ATSW,ATSWX ;Says ask or type FORMAT: BLOCKV MANDIG,MDIGX,6 ;Number of digits to type for mantissa BLOCKV NFRAC,NFRACX,3 ;Number of digits to type for fraction BLOCKB NUMDIG,NUMDGX ;Number of digits input by user BLOCKB FLCEXP,FLACEX ;Flac exponent BLOCKB FLCM1,FLACM1 ;Flac mantissa BLOCKB FLCM2,FLACM2 ; ... BLOCKB FLCM3,FLACM3 ; ... BLOCKB FLCM4,FLACM4 ;Extended half of flac BLOCKB FLCM5,FLACM5 ; ... .IFZ FBYTES-4 BLOCKW FLCM6,FLACM6 ; ... .ENDC .IFZ FBYTES-6 BLOCKB FLCM6,FLACM6 BLOCKB FLCM7,FLACM7 BLOCKB FLCM8,FLACM8 BLOCKB FLCM9,FLACM9 BLOCKW FLCMA,FLACMA .ENDC BLOCKB SIGN,SIGNX ;Sign byte BLOCKB PTMPX,PTMPEX ;Temp flac BLOCKB PTMP1,PTMPM1 ;Mantissa BLOCKB PTMP2,PTMPM2 ; ... BLOCKB PTMP3,PTMPM3 ; ... .IFZ FBYTES-6 BLOCKB PTMP4,PTMPM4 BLOCKB PTMP5,PTMPM5 .ENDC BLOCKB FTMPX,FTMPEX ;Another temp flac BLOCKB FTMP1,FTMPM1 ; ... BLOCKB FTMP2,FTMPM2 ; ... BLOCKB FTMP3,FTMPM3 ; ... .IFZ FBYTES-6 BLOCKB FTMP4,FTMPM4 BLOCKB FTMP5,FTMPM5 .ENDC .IFNZ FTEXFN BLOCKB CTMPX,CTMPEX ;Temp for cosine BLOCKB CTMP1,CTMPM1 ; ... BLOCKB CTMP2,CTMPM2 ; ... BLOCKB CTMP3,CTMPM3 ; ... .IFZ FBYTES-6 BLOCKB CTMP4,CTMPM4 BLOCKB CTMP5,CTMPM5 .ENDC BLOCKB STMPX,STMPEX ; ... BLOCKB STMP1,STMPM1 ; ... BLOCKB STMP2,STMPM2 ; ... BLOCKB STMP3,STMPM3 ; ... .IFZ FBYTES-6 BLOCKB STMP4,STMPM4 BLOCKB STMP5,STMPM5 .ENDC .ENDC BLOCKB TLINE,TLINEX ;Temp line number BLOCKB TGRP,TGRPX ;Temp group number BLOCKW VSUB,VSUBX ;Place to store subscript BLOCKB VCHAR,VCHARX ;Place to store variable name BLOCKB THISOP,THSOPX ;Current op BLOCKB LASTOP,LSTOPX ;Last op .EOT .SBTTL Program storage area COMBUF=. ;Space for the input command .BYTE 'W ;Write out the version number at startup .BYTE CR .=COMBUF+127 ;Max of 127 characters per line PRGBEG=. ;Start of program area .BYTE 0 ;Dummy line to start program .BYTE 0 ;00.00 .ASCII \ C FOCAL-Z80 version 1E for CP/M, 17-May-84\ .BYTE CR ;End of line PRGINI=. ;Place to initialize program text .BYTE EOP ;End of program .IFNZ FTINDX .ADDR 0 ;Pointer to line zero .ADDR PRGBEG ; ... .BYTE EOI ;End of index .ENDC INIVAR: .BYTE EOV ;End of variables STKADR=MEMSIZ ;Put stack at top of memory PRGSPC=STKADR-PRGINI ;Print amout of memory for program .EOT .SBTTL Device dependent I/O definitions ; *** I/O definition file for Z80 programs *** ; ; ; I/O definitions for my digital group system, wayne wall, june 1978. ; ; ; all I/O definitions are kept in this file for ease of modification ; and maintenance. ; ;Entry points to device dependent driver routines. .IFZ FTCPM TVINI=$0503 ;Dg tv initialization routine TVOUT=$0544 ;Output a char to dg tv KEYIN=$0630 ;Input a char from keyboard TVCUR=$051B ;Cursor address the tv screen CONCUR=TVCUR ;General cursor addressing routine .ENDC ;Here if device does not need a given routine. DUMIO: ORA A ;Clear c bit to indicate success RET ;And return to caller ;Here if no handler for a given device slot. NOHAN: STC ;Set carry flag to indicate failure RET ;And return to caller .SBTTL I/O dispatch tables ;Dispatch table to initialize input devices INIDSP: .ADDR DUMIO ;Keyboard .ADDR NOHAN ;Space for hackers .ADDR NOHAN .ADDR NOHAN .ADDR NOHAN .ADDR NOHAN .ADDR NOHAN .ADDR NOHAN ;Dispatch table to initialize output devices INODSP: .ADDR TVINI ;Digital group tv .ADDR NOHAN ;Space for hackers .ADDR NOHAN .ADDR NOHAN .ADDR NOHAN .ADDR NOHAN .ADDR NOHAN .ADDR NOHAN ;Dispatch table to close input devices CLIDSP: .ADDR DUMIO ;Keyboard .ADDR NOHAN ;Space for hackers .ADDR NOHAN .ADDR NOHAN .ADDR NOHAN .ADDR NOHAN .ADDR NOHAN .ADDR NOHAN ;Dispatch table to close output devices CLODSP: .ADDR DUMIO ;Digital group tv .ADDR NOHAN ;Space for hackers .ADDR NOHAN .ADDR NOHAN .ADDR NOHAN .ADDR NOHAN .ADDR NOHAN .ADDR NOHAN ;Dispatch table for device input routines IDSP: .ADDR KEYIN ;Input a character from keyboard .ADDR NOHAN ;Space for hackers .ADDR NOHAN .ADDR NOHAN .ADDR NOHAN .ADDR NOHAN .ADDR NOHAN .ADDR NOHAN ;Dispatch table for device output routines ODSP: .ADDR TVOUT ;Output a character to digital group tv .ADDR NOHAN ;Space for hackers .ADDR NOHAN .ADDR NOHAN .ADDR NOHAN .ADDR NOHAN .ADDR NOHAN .ADDR NOHAN .IFNZ FTCPM ;A "jmp 0" or "rst0" will re-boot cpm. ;Location $0038 has either a "ret" or "jmp ddt" so that either "rst7" or ;"call $38" will return control to ddt. KEYIN: NOP ;For patching NOP NOP MVI C,6 ;Direct console I/O MVI E,$FF ;Ff means return non-zero if input ready CALL 0005 ;Call bdos CPI 3 ;Control-c? JNZ KEYIN1 ;No LDA KEYINC ;Yes, get last character CPI 3 ;Was it also control-c? JZ 0000 ;Yes, abort to cp/m MVI A,3 ;No, store control-c STA KEYINC ; as last character input JMP START ;Restart FOCAL on single control-c KEYINC: .BYTE 0 KEYIN1: ORA A ;Clear the carry bit and check for zero JZ KEYIN ;Wait for a key to be pressed STA KEYINC ;Remember last input RET ;Character is in a TVOUT: NOP ;For patching NOP NOP MVI C,6 ;Direct console I/O MOV E,A ;Character to output CALL 0005 ;Call bdos MVI C,6 MVI E,$FF ;Check for input during type-out CALL 0005 CPI 3 ;Control-c? JZ START ;Yes, abort ORA A ;Clear the carry bit RZ ;Return if no input STA KEYINC ;Remember last character typed in RET TVINI: NOP ;Initialize console ORA A RET TVCUR: NOP ;Cursor position, d=col, e=row ORA A RET CONCUR=TVCUR .ENDC .END