.PROC INTERP ; Includes for the Z80/8080 Interpreter .INCLUDE Z8080:INTERP.TEXT ;********************************************************; ;* *; ;* UCSD Pascal Interpreter for *; ;* Zilog Z-80/Intel 8080A *; ;* *; ;* Written by Peter A. Lawrence *; ;* and Joel J. McCormack *; ;* *; ;* Written during Summer/Fall 1977 *; ;* I.4 Released Mar. 1978 *; ;* I.5 Released Sep. 1978 *; ;* *; ;* For Institute for Information Systems *; ;* UC San Diego, La Jolla, CA *; ;* *; ;* Copyright (c) 1978 *; ;* Regents of the University of California *; ;* Permission to copy or distribute this software *; ;* in hard or soft copy granted only by written *; ;* license obtained from the Institute for *; ;* Information Systems. *; ;* *; ;********************************************************; ; 20-Jul-78 JJM Div and mod bug fixed ; 19-Aug-78 JJM Transcendental functions added ; 13-Sep-78 JJM Set comparison bug fixed ; 13-Sep-78 JJM String comparison bug fixed ; 16-Sep-78 JJM Assembly procedure facilities added .IF LSTINT .LIST .ELSE .NOLIST .ENDC ;****************** MACRO DEFINITIONS *******************; .MACRO RETURN JP BACK .ENDM .MACRO RESTORE JP BACK1 .ENDM .MACRO TSTA AND A .ENDM .MACRO CLRA XOR A .ENDM .MACRO CLRCF AND A .ENDM .IF Z80 .MACRO NEGA NEG .ENDM .MACRO SAVIPC LD (IPCSAV),BC .ENDM .MACRO GETIPC LD BC,(IPCSAV) .ENDM .MACRO DJNZM DJNZ %1 .ENDM .MACRO SUBHLDE AND A SBC HL,DE .ENDM .MACRO SUBHLBC AND A SBC HL,BC .ENDM .MACRO SELREL SCF SBC HL,DE LD C,L LD B,H .ENDM .ENDC .IF ~Z80 .MACRO NEGA CPL INC A .ENDM .MACRO SAVIPC LD L,C LD H,B LD (IPCSAV),HL .ENDM .MACRO GETIPC LD HL,(IPCSAV) LD C,L LD B,H .ENDM .MACRO DJNZM DEC B JP NZ,%1 .ENDM .MACRO SUBHLDE LD A,L SUB E LD L,A LD A,H SBC A,D LD H,A .ENDM .MACRO SUBHLBC LD A,L SUB C LD L,A LD A,H SBC A,B LD H,A .ENDM .MACRO SELREL SCF LD A,L SBC A,E LD C,A LD A,H SBC A,D LD B,A .ENDM .ENDC ;******************** TRANSFER TABLE ********************; .ORG ROM XFRTBL .WORD ABI .WORD ABR .WORD ADI .WORD ADR .WORD LAND .WORD DIF .WORD DVI .WORD DVR .WORD CHK .WORD FLO .WORD FLT .WORD INN .WORD INT .WORD LOR .WORD MODI .WORD MPI .WORD MPR .WORD NGI .WORD NGR .WORD NOT .WORD SRS .WORD SBI .WORD SBR .WORD SGS .WORD SQI .WORD SQR .WORD STO .WORD IXS .WORD UNI .WORD S2P .WORD CSP .WORD LDCN .WORD ADJ .WORD FJP .WORD INCR .WORD STIND .WORD IXA .WORD LAO .WORD LCA .WORD LDO .WORD MOV .WORD MVB .WORD SAS .WORD SRO .WORD XJP .WORD RNP .WORD CIP .WORD CEQU .WORD CGEQ .WORD CGTR .WORD LDA .WORD LDC .WORD CLEQ .WORD CLSS .WORD LOD .WORD CNEQ .WORD STR .WORD UJP .WORD LDP .WORD STP .WORD LDM .WORD STM .WORD LDB .WORD STB .WORD IXP .WORD RBP .WORD CBP .WORD EQUI .WORD GEQI .WORD GTRI .WORD LLA .WORD LDCI .WORD LEQI .WORD LESI .WORD LDL .WORD NEQI .WORD STL .WORD CXP .WORD CLP .WORD CGP .WORD S1P .WORD IXB .WORD BYT .WORD EFJ .WORD NFJ .WORD BPT .WORD ABORT .WORD BACK .WORD SLDL, SLDL, SLDL, SLDL, SLDL, SLDL, SLDL, SLDL .WORD SLDL, SLDL, SLDL, SLDL, SLDL, SLDL, SLDL, SLDL .WORD SLDO, SLDO, SLDO, SLDO, SLDO, SLDO, SLDO, SLDO .WORD SLDO, SLDO, SLDO, SLDO, SLDO, SLDO, SLDO, SLDO .WORD SIND0 .WORD SIND, SIND, SIND, SIND, SIND, SIND, SIND GOLOC JP BOOT ; Jump to Pascal-level booter (entry point ; for booters that only read in interp) .IF ~NMS INTENT ; Entry point for complex booter POP HL ; Get the address of BIOS jump table LD (BIOSJP),HL ; Save it for jump address calculations JP BACK1 ; GO FOR IT BIOSJP .WORD 0 ; Vector to the BIOS jump table .BLOCK 4H .ENDC .IF NMS ;Stuff for Northwest Micro disk densitys .BLOCK 3 ;to align with I.4 FLGLF .BYTE 0FFH FMTD0 .BYTE 0 FMTD1 .BYTE 0 .BLOCK 7H ; for expansion .ENDC ; Arithmetic operations jump table JP MULT ; HL := BC*DE JP DIVPOS ; JP DIVD JP FPFADD JP FPFSUB JP FPFMUL JP FPFDIV JP FPFFLOAT JP FPFFIX JP FPFNEG JP FPFABS JP FPFSQR JP FPFINV JP FPFRND JP FPFPOT ;********* INTERPRETER CONSTANTS AND VARIBLES **********; ; Constants NIL .EQU 0001H ; value of NIL pointer MAXSEG .EQU 0FH ; max segment # MSCWSIZE .EQU 0CH ; size of a mark stack control word DISP0 .EQU 0AH ; Offset from MSSTAT of variable with offset ; of 0 ; Internal P-machine registers, widely used temporaries .ALIGN 2 NP .WORD 0 ; ^top_of_heap MPD0 .WORD 0 ; ^local var with offset of zero BASED0 .WORD 0 ; ^global var with offset of zero IPCSAV .WORD 0 ; save IPC on complex ops, and for XEQERR FPERROR .WORD 0 ; fp error status RETADR .WORD 0 NEWSP .WORD 0 LTSTRNG .BYTE 01H ; char to string conversion .BYTE 0 ; Internal segment table, contains refcounts and addr of each seg .ALIGN 2 INTSEGT .BLOCK *4 ; General use reusable temporaries WORD1 .WORD 0 WORD2 .WORD 0 WORD3 .WORD 0 WORD4 .WORD 0 BLOCK1 .BLOCK 08H BYTE1 .WORD 0 ; Transcendental fp temporaries TFPT .BLOCK 26. ; Procedure temporaries TPROC .BLOCK 20. ;************************ SYSCOM ************************; .ALIGN 2 SYSCOM ; Interpreter and pascalsystem communication area IORSLT .WORD 0 XERRCD .WORD 0 SYSUNT .WORD 04H BUGSTA .WORD 0 GDIRP .WORD NIL BOMBP .WORD 0 BASE .WORD 0 MP .WORD 0 JTAB .WORD 0 SEGP .WORD 0 MEMTOP .WORD MAXADR ; we hope BOMIPC .WORD 0 HLTLINE .WORD 0 BRKPTS .BLOCK 2*4 .BLOCK 2*10. LOTIME .WORD 0 HITIME .WORD 0 MSCNFO .WORD 0000H ; has xy addressing, has lowercase CRTTYP .WORD 0000H CRTCTL ; output to CONSOLE: .BYTE 00H ; escape .BYTE 0DH ; [EM] - home .BYTE 00H ; [VT] - eraseeos .BYTE 00H ; [GS] - eraseeol .BYTE 21H ; [FS] - non-destructive forward space .BYTE 00H ; [US] - reverse line feed .BYTE 08H ; [BS] - backspace .BYTE 05H ; fillcount .BLOCK 04H ; expansion CRTNFO .WORD 18H ; height WIDTH .WORD 50H ; width ; input from CONSOLE: .BYTE 1FH ; [US] - up .BYTE 0AH ; [LF] - down .BYTE 08H ; [BS] - left .BYTE 1CH ; [FS] - right SYEOF .BYTE 03H ; ^C FLUSH .BYTE 06H ; ^F BREAK .BYTE 00H STOP .BYTE 13H ; ^S .BYTE 08H ; ^H - chardel .BYTE 3FH ; ? - badch .BYTE 7FH ; [del] - linedel .BYTE 1BH ; [esc] - altmode .BLOCK 06H ; expansion SEGTBL .BLOCK 2*3* ;********************** I - FETCH ***********************; BACK1 GETIPC JP BACK SLDCI ; Short load constant word RRA LD L,A LD H,00H PUSH HL BACK LD A,(BC) ; get opcode INC BC ; increment IPC ADD A,A JP NC,SLDCI ; if bit 7 zero push constant ; else decode op and jump to routine LD H,ROM/100H LD L,A ; HL points to routine address in jump table LD E,(HL) ; get address INC HL LD D,(HL) EX DE,HL JP (HL) ; and go there ;**************** RUN-TIME ERROR SUPPORT ****************; XEQERR ; a run-time error has occured. pass some parameters ; through syscom, then do a CXP 0,2 (PROCEDURE execerror) LD H,00H ; HL = error # LD (XERRCD),HL LD HL,-14. ; size of execerror stack frame (MSCW+with temp) ADD HL,SP LD (BOMBP),HL ; (BOMBP) := ^exerror MSCW LD HL,(IPCSAV) LD (BOMIPC),HL LD BC,CXP02 NOP ; leave here - handy for debugging JP BACK CXP02 .BYTE 77.+128., 0, 2 INVNDX LD L,01H ; Invalid index JP XEQERR NOPROC LD L,02H ; Non-existent segment JP XEQERR NOEXIT LD L,03H ; Exitting procedure never called JP XEQERR STKOVR LD HL,INTEND ; stack overflow LD (NP),HL ; prevent recursive overflow LD L,04H JP XEQERR INTOVR LD L,05H ; Integer overflow JP XEQERR DIVZER LD L,06H ; Divide by zero JP XEQERR BADMEM LD L,07H ; Bad memory access (PDP-11 error only) JP XEQERR UBREAK LD L,08H ; User break JP XEQERR SYIOER LD L,09H ; System IO error JP XEQERR UIOERR LD L,0AH ; User IO error JP XEQERR NOTIMP SAVIPC ; Instruction not implemented LD L,0BH JP XEQERR FPIERR LD L,0CH ; Floating point error JP XEQERR S2LONG LD L,0DH ; String too long JP XEQERR HLT SAVIPC ; Unconditional halt LD L,0EH JP XEQERR BPTHLT LD L,0FH ; Conditional halt or breakpoint JP XEQERR BPT ; Conditional halt or breakpoint CALL GBDE EX DE,HL ; save line number LD (HLTLINE),HL EX DE,HL SAVIPC LD A,(BUGSTA) CP 3 JP P,BPTHLT ; not in stepping mode, so check for breakpoint LD HL,BRKPTS LD B,4 $10 LD A,E CP (HL) INC HL JP NZ,$20 LD A,D CP (HL) JP Z,BPTHLT $20 INC HL DJNZM $10 JP BACK1 ; End-of-File INTERP .INCLUDE Z8080:VARS.TEXT .IF ~LSTVARS .NOLIST .ELSE .LIST .ENDC ;Copyright (c) 1978 ; by the Regents of the University of California, San Diego ; start of file VARS ;********** LOADING, STORING, INDEXING, AND MOVING **********; ;****The rest of the load constant word instructions LDCI ; Load constant word LD A,(BC) ; low byte LD L,A INC BC LD A,(BC) ; high byte LD H,A INC BC PUSH HL JP BACK LDCN ; Load constant nil pointer LD HL,NIL PUSH HL JP BACK GBDE ; get a big (possibly two byte) constant from code into DE LD A,(BC) INC BC LD E,A ; assume 1-byte...by far the most common case LD D,00H TSTA RET P ; if bit 7 is zero, assumtion was correct AND 7FH ; clear bit 7 LD D,A ; this is the high order byte LD A,(BC) ; get lower INC BC LD E,A RET ;***** Local vars SLDL ; Short load local word ADD A,52H ; get displacement from opcode LD E,A ; DE := displacement LD D,00H LD HL,(MPD0) ADD HL,DE ; compute address of var LD E,(HL) ; load the data INC HL LD D,(HL) PUSH DE JP BACK LLA ; Load local address CALL GBDE LD HL,(MPD0) ADD HL,DE ADD HL,DE PUSH HL JP BACK LDL ; Load local word CALL GBDE LD HL,(MPD0) ADD HL,DE ADD HL,DE LD E,(HL) INC HL LD D,(HL) PUSH DE JP BACK STL ; Store local word CALL GBDE LD HL,(MPD0) ADD HL,DE ADD HL,DE POP DE LD (HL),E INC HL LD (HL),D JP BACK ;***** Global vars SLDO ; Short load global word - just like SLDL ADD A,32H LD E,A LD D,00H LD HL,(BASED0) ADD HL,DE LD E,(HL) INC HL LD D,(HL) PUSH DE JP BACK LAO ; Load global address CALL GBDE LD HL,(BASED0) ADD HL,DE ADD HL,DE PUSH HL JP BACK LDO ; Load global word CALL GBDE LD HL,(BASED0) ADD HL,DE ADD HL,DE LD E,(HL) INC HL LD D,(HL) PUSH DE JP BACK SRO ; Store global word CALL GBDE LD HL,(BASED0) ADD HL,DE ADD HL,DE POP DE LD (HL),E INC HL LD (HL),D JP BACK ;***** Intermediate vars GETIA ; Get intermediate address into HL. Routine used by LDA, LOD, STR LD A,(BC) ; # of lex levels to chain (always > 1) INC BC LD HL,(MP) $10 LD E,(HL) ; go up static links till reach proper MSCW INC HL LD D,(HL) EX DE,HL DEC A JP NZ,$10 CALL GBDE ; get displacement... ADD HL,DE ; ...and calculate address ADD HL,DE LD DE,DISP0 ADD HL,DE RET LDA ; Load intermediate address CALL GETIA PUSH HL JP BACK LOD ; Load intermedate word CALL GETIA LD E,(HL) INC HL LD D,(HL) PUSH DE JP BACK STR ; Store intermediate word CALL GETIA POP DE LD (HL),E INC HL LD (HL),D JP BACK ;***** Indirect, Records, Arrays, and Indexing INCR ; Increment (SP) by literal CALL GBDE POP HL ADD HL,DE PUSH HL JP BACK STO ; Store indirect POP DE ; value POP HL ; address LD (HL),E INC HL LD (HL),D JP BACK SIND0 ; Short index and load word, index=0 (load indirect) POP HL LD E,(HL) INC HL LD D,(HL) PUSH DE JP BACK SIND ; Short static index and load word POP HL ; get array base address ADD A,10H ; calculate index from opcode LD E,A LD D,00H ADD HL,DE ; calculate address LD E,(HL) ; and load the value INC HL LD D,(HL) PUSH DE JP BACK STIND ; Static index and load word POP HL ; base address CALL GBDE ; get index from code ADD HL,DE ADD HL,DE LD E,(HL) ; load the word INC HL LD D,(HL) PUSH DE ; and stick it on the stack JP BACK IXA ; Index array ; Given an array element_size in code stream, ; an index and array base address on stack, ; compute the indexed address and push it. CALL GBDE ; DE := element_size SAVIPC POP BC ; BC := index LD H,B ; Check if element_size = 1 LD L,C LD A,E DEC A OR D CALL NZ,MULT ADD HL,HL ; make into word offset POP BC ; get array base ADD HL,BC PUSH HL JP BACK1 MOV ; Move words CALL GBDE ; DE := number of words to move SAVIPC .IF Z80 LD A,E ; BC := number of bytes to move ADD A,A LD C,A LD A,D ADC A,D LD B,A POP HL ; HL := ^source POP DE ; DE := ^dest LDIR ; move the stuff in one swell foop JP BACK1 .ENDC .IF ~Z80 CLRA ; BC := -number of words to move SUB E ; (allows counting up to zero) LD C,A LD A,00H SBC A,D LD B,A POP HL ; HL := ^source POP DE ; DE := ^dest $10 LD A,(HL) ; move a word INC HL LD (DE),A INC DE LD A,(HL) INC HL LD (DE),A INC DE INC C ; loop control JP NZ,$10 INC B JP NZ,$10 JP BACK1 .ENDC ;***** Multiple word vars (sets and reals) LDC ; Load multiple word constant (constant is backwards in code stream) LD A,(BC) ; A := number of words long LD HL,0002H ; put HL on a word boundary ADD HL,BC LD B,A ; B := # words to move LD A,L AND 0FEH LD L,A $10 LD E,(HL) ; transfer the stuff from code... INC HL LD D,(HL) INC HL PUSH DE ; ...to stack DJNZM $10 LD C,L ; fix up IPC LD B,H JP BACK LDM ; Load multiple words (no more than 255) POP DE ; DE := ^source LD A,(BC) ; A := number of words to transfer INC BC TSTA JP Z,BACK ; just in case...supposedly unnecessary LD L,A ; HL := ^word following source LD H,00H ADD HL,HL ADD HL,DE $10 DEC HL ; get words from dest... LD D,(HL) DEC HL LD E,(HL) PUSH DE ; ...and put them on the stack. DEC A JP NZ,$10 JP BACK STM ; Store multiple words LD A,(BC) ; Number of words to transfer INC BC TSTA JP Z,$20 ; Again, just in case! LD L,A ; HL := ^dest (the pointer is buried under all LD H,00H ; the words that need to be transferred) ADD HL,HL ADD HL,SP LD E,(HL) INC HL LD D,(HL) EX DE,HL $10 POP DE ; Transfer stuff from stack... LD (HL),E ; ...to dest. INC HL LD (HL),D INC HL DEC A JP NZ,$10 $20 POP HL ; junk ^dest JP BACK ;***** Character vars, and byte array vars LDB ; Load byte POP HL ; HL := ^char LD E,(HL) LD D,00H PUSH DE JP BACK STB ; Store byte POP DE ; E := char POP HL ; HL := ^dest LD (HL),E ; store it JP BACK MVB ; Move bytes CALL GBDE ; DE := number of bytes to move SAVIPC .IF Z80 LD C,E LD B,D POP HL ; HL := ^source POP DE ; DE := ^dest LDIR ; transfer the stuff .ENDC .IF ~Z80 CLRA ; BC := -number bytes to move SUB E LD C,A LD A,00H SBC A,D LD B,A POP HL ; ^source POP DE ; ^dest $10 LD A,(HL) ; move the stuff INC HL LD (DE),A INC DE INC C ; loop control JP NZ,$10 INC B JP NZ,$10 .ENDC JP BACK1 IXB ; Index byte array POP DE ; DE := index POP HL ; HL := array base address ADD HL,DE PUSH HL JP BACK ;***** String vars ; A String is... ; The first byte contains the current number of characters ; in the string. (0..declared_size) ; The next bytes are those characters, with garbage fill ; out to the declared_size of the string. ; ; Declared_size (<= 255) is in the instruction stream for instructions ; that need to know. LCA ; Load constant string address ; The string is in the code. Put its address on ; the stack and move the IPC past it PUSH BC ; Address of string LD A,(BC) ; Get number of characters in string INC BC ; Skip over length byte ADD A,C ; Skip over characters LD C,A LD A,00H ADC A,B LD B,A JP BACK IXS ; Index string pointer ; Given index, ^string, compute ^string[index] POP DE ; index POP HL ; ^string CLRA ; Make sure 1 <= index <= 255 OR D JP NZ,$99 OR E JP Z,$99 CP (HL) ; make sure index <= current length JP C,$20 JP NZ,$99 $20 ADD HL,DE ; Perform indexing PUSH HL JP BACK $99 INC HL PUSH HL ; leave ^string[1] on top of stack SAVIPC JP INVNDX SAS ; String assignment ; On stack can be either ; ^src_string, ^dst_string or ; a character, ^dst_string MAXLEN .EQU BYTE1 LD A,(BC) ; Save declared_size of dest LD (MAXLEN),A INC BC SAVIPC POP HL ; get the source LD A,H ; and see if char or ^string TSTA ; char has zero upper byte JP NZ,$10 LD A,L LD (LTSTRNG+1),A ; turn the char into a string LD HL,LTSTRNG ; and point HL at it $10 LD C,(HL) ; make sure source is not longer $20 LD A,(MAXLEN) ; than declared_size of dest CP C JP C,$99 POP DE ; DE := ^dst_string .IF Z80 LD B,00H INC BC ; include length byte LDIR .ENDC .IF ~Z80 INC C ; include length byte $30 LD A,(HL) LD (DE),A INC HL INC DE DEC C JP NZ,$30 .ENDC JP BACK1 $99 POP HL ; junk ^dst JP S2LONG BYT .EQU BACK ; comvert word to byte address S1P ; String to packed array on top of stack POP DE INC DE ; just point pointer past length byte PUSH DE JP BACK S2P ; String to packed array of char under tos POP HL POP DE INC DE PUSH DE PUSH HL JP BACK ;***** Packed arrays and record IXP ; Index a packed array ; Given... ; elements_per_words, bits_per_element in code stream, ; index, base address of array on stack ; Compute... ; right_bit_number, bits_per_element, ^indexed_word ELTLEN .EQU WORD1 LD A,(BC) ; E := elements_per_word LD E,A INC BC LD A,(BC) ; (ELTLEN) := bits_per_element LD (ELTLEN),A INC BC SAVIPC POP HL ; HL := index LD C,E ; BC := elements_per_word LD B,00H CALL DIVPOS ; HL := index in words, DE := remainder EX DE,HL ADD HL,HL ; HL := ^indexed word POP BC ADD HL,BC PUSH HL ; push ^indexed word $10 LD A,(ELTLEN) ; HL := bits_per_element LD L,A LD H,00H PUSH HL LD B,L ; Compute right_bit_number := CLRA ; remainder*bits_per_element $20 ADD A,E DJNZM $20 LD L,A PUSH HL ; push right_bit_number JP BACK1 LDP ; Load a packed field ; get the field described by ; right_bit_number, ; bits_per_element ; ^word. all info is on the stack SAVIPC POP DE ; B := right_bit_number LD B,E POP DE ; C := bits_per_element LD C,E POP HL ; DE := word field is in LD E,(HL) INC HL LD D,(HL) ; position the field by a bunch of right shifting LD A,B ; see if shift >= 8 bits SUB 08H JP C,$10 LD B,A ; B := future right_bit_number LD L,D ; swap bytes LD D,E LD E,L JP NZ,$20 ; if amount left to shift>0, do it JP $30 $10 ADD A,08H ; restore amount to shift, and test if zero JP Z,$30 $20 ; do the actual shifting .IF Z80 SRL D RR E .ENDC .IF ~Z80 LD A,D RRA LD D,A LD A,E RRA LD E,A .ENDC DJNZM $20 $30 LD HL,CLRMSK ; clear out all the junk in high order bits ADD HL,BC ADD HL,BC ; HL = ^CLRMSK[bits_per_element] LD A,(HL) AND E LD E,A INC HL LD A,(HL) AND D LD D,A PUSH DE ; push the cleaned field JP BACK1 STP ; Store into a packed field ; Given data, right_bit_number, bits_per_element, ^target SAVIPC POP DE ; DE := data POP BC ; A := right_bit_number LD A,C POP BC ; BC := CLRMSK[bits_per_word] LD HL,CLRMSK ADD HL,BC ADD HL,BC LD C,(HL) INC HL LD B,(HL) ; left shift data and mask SUB 08H ; shift >= 8 bits ? JP C,$10 LD L,A ; save future # of bits to shift LD H,B ; swap bytes of mask LD B,C LD C,H LD H,D ; and of data. LD D,E LD E,H JP NZ,$20 ; go on to shifting if necessary JP $30 $10 ADD A,08H ; right_bit_number < 8, so restore JP Z,$30 ; see if = 0 LD L,A ; and stick into loop control variable CLRCF $20 ; do the shifting .IF Z80 SLA E RL D SLA C RL B .ENDC .IF ~Z80 LD A,E RLA LD E,A LD A,D RLA LD D,A LD A,C RLA LD C,A LD A,B RLA LD B,A .ENDC DEC L JP NZ,$20 $30 POP HL ; HL = ^word LD A,C ; insert low byte CPL AND (HL) OR E LD (HL),A INC HL ; insert high byte LD A,B CPL AND (HL) OR D LD (HL),A JP BACK1 CLRMSK .WORD 0000H BITTER .WORD 0001H ; used by set stuff .WORD 0003H .WORD 0007H .WORD 000FH .WORD 001FH .WORD 003FH .WORD 007FH .WORD 00FFH .WORD 01FFH .WORD 03FFH .WORD 07FFH .WORD 0FFFH .WORD 1FFFH .WORD 3FFFH .WORD 7FFFH .WORD 0FFFFH ; End-of-File VARS .INCLUDE Z8080:ARITH.TEXT .IF ~LSTARIT .NOLIST .ELSE .LIST .ENDC ;Copyright (c) 1978 ; by the Regents of the University of California, San Diego ; start of file ARITH ;*************** TOP OF STACK ARITHMETIC ****************; ;***** Logical LAND ; Logical AND POP DE POP HL LD A,E AND L LD L,A LD A,D AND H LD H,A PUSH HL JP BACK LOR ; Logical OR POP HL POP DE LD A,L OR E LD L,A LD A,H OR D LD H,A PUSH HL JP BACK NOT ; Logical NOT POP HL LD A,L CPL LD L,A LD A,H CPL LD H,A PUSH HL JP BACK ;***** Integer ABI ; Integer absolute value POP HL LD A,H TSTA JP P,$10 CLRA SUB L LD L,A LD A,00H SBC A,H AND 7FH ; in case of -32768 LD H,A $10 PUSH HL JP BACK ADI ; Add integers POP DE POP HL ADD HL,DE PUSH HL JP BACK DVI ; Divide integers SAVIPC POP BC ; divisor POP DE ; dividend CALL DIVD PUSH DE ; quotient JP BACK1 MODI ; Remainder of integer division SAVIPC POP BC POP DE CALL DIVD PUSH HL JP BACK1 MPI ; Integer multiply SAVIPC POP DE POP BC CALL MULT PUSH HL JP BACK1 SQI ; Square integers SAVIPC POP DE LD C,E LD B,D CALL MULT PUSH HL JP BACK1 NGI ; Negate integer POP HL CLRA SUB L LD L,A LD A,00H SBC A,H LD H,A PUSH HL JP BACK SBI ; Subtract integers POP DE POP HL SUBHLDE PUSH HL JP BACK CHK ; Check number against limits (range-checking) POP HL ; max POP DE ; min EX (SP),HL ; HL = num, DE = min, (SP) = max LD A,D XOR H JP M,$10 LD A,L SUB E LD A,H SBC A,D JP P,$20 JP $98 $10 AND D JP P,$98 $20 POP DE ; max PUSH HL ; put num back ; HL = num, DE = max LD A,D XOR H JP M,$30 LD A,E ; is max >= num ? SUB L LD A,D SBC A,H JP P,BACK JP $99 $30 AND H JP M,BACK JP $99 $98 EX (SP),HL ; leave num on stack to help person debug $99 SAVIPC JP INVNDX ;***************TEMPORARY EXPEDIENT MULT ; Two's complement integer multiply routine ; Entry BC = multiplicand, DE = multiplier ; Exit HL = product .IF Z80 LD HL,0000H $10 SRL D JP NZ,$20 RR E JP Z,$50 JP $30 $20 RR E $30 JP NC,$40 ADD HL,BC $40 SLA C RL B JP $10 $50 JP NC,$60 ADD HL,BC $60 RET .ENDC .IF ~Z80 EX DE,HL ; make HL multiplicand LD DE,0000H ; and DE product LD A,C ; A := lower 8 bits of multiplier $10 LD C,B ; set up next 8 bits for next time around LD B,08H ; B := shift count $20 RRA JP NC,$30 EX DE,HL ; add in the partial product ADD HL,DE EX DE,HL $30 ADD HL,HL ; shift multiplicand left DEC B JP NZ,$20 LD A,C ; get high order byte of multiplier TSTA JP NZ,$10 EX DE,HL ; put the product in HL to meet specs RET .ENDC DIVPOS ; Divide two positive integers ; Entry BC = divisor, HL = dividend ; Exit BC = divisor, HL = remainder ; DE = quotient SHFTCT .EQU BYTE1 .IF Z80 LD DE,0000H LD A,01H $10 INC A SLA C RL B JP P,$10 $20 SCF RL E RL D SBC HL,BC JP NC,$30 ADD HL,BC DEC DE $30 SRL B RR C DEC A JP NZ,$20 RL C RL B RET .ENDC .IF ~Z80 ; make HL divisor, DE dividend while shifting divisor left EX DE,HL LD H,B LD L,C CLRA $10 INC A ; A is shift count ADD HL,HL JP NC,$10 ; for main loop, BC = divisor, DE = what's left of dividend, ; HL = quotient so far LD C,L LD B,H LD HL,0000H $20 LD (SHFTCT),A LD A,B ; shift divisor right RRA LD B,A LD A,C RRA LD C,A ADD HL,HL ; shift quotient left LD A,E ; dividend := dividend-divisor SUB C LD E,A LD A,D SBC A,B LD D,A JP NC,$30 EX DE,HL ; shit. restore dividend ADD HL,BC EX DE,HL CLRCF ; for shifting divisor right JP $40 $30 INC HL ; subtract was okay $40 LD A,(SHFTCT) DEC A JP NZ,$20 EX DE,HL ; satisfy exit conditions specified above RET .ENDC DIVD ; Two's complement divide - mathematically correct even! ; NOTE WELL. Does not return values as specified in J & W. ; Entry BC = divisor, DE = dividend ; Exit HL = remainder, DE = quotient CLRA ; make sure divisor isn't 0 or -32768 OR C JP NZ,$10 OR B JP Z,$99 XOR 80H JP Z,$99 $10 LD A,B ; check divisor sign TSTA JP M,$50 $20 OR D ; check dividend sign JP M,$40 $30 EX DE,HL ; divide positive by positive CALL DIVPOS ; no adjustment necessary. 7 DIV 3 = 2, 7 MOD 3 = 1 ; 6 DIV 3 = 2, 6 MOD 3 = 0 RET $40 ; divide negative by positive LD A,E ; dividend := -dividend-1 CPL LD L,A LD A,D CPL LD H,A CALL DIVPOS ; now set realquotient := -quotient-1 ; realremainder := divisor-remainder-1 ; -7 DIV 3 = -3, -7 MOD 3 = 2 ; -6 DIV 3 = -2, -6 MOD 3 = 0 LD A,E CPL LD E,A LD A,D CPL LD D,A ; now for the remainder SCF LD A,C SBC A,L LD L,A LD A,B SBC A,H LD H,A RET $50 ; divide by negative. make divisor positive. CLRA SUB C LD C,A LD A,00H SBC A,B LD B,A LD A,D ; check dividend sign TSTA JP M,$80 JP NZ,$60 OR E JP Z,$80 ; makes things cleanest, believe it or not $60 EX DE,HL ; divide positive by negative DEC HL CALL DIVPOS ; now set realquotient := -quotient-1, ; realremainder := remainder+1-divisor ; 7 DIV -3 = -3, 7 MOD -3 = -2 ; 6 DIV -3 = -2, 6 MOD -3 = 0 LD A,E CPL LD E,A LD A,D CPL LD D,A $70 SUBHLBC INC HL RET $80 ; divide negative or zero by negative CLRA ; make dividend positive SUB E LD L,A LD A,00H SBC A,D LD H,A CALL DIVPOS ; now set realremainder := -realremainder ; -7 DIV -3 = 2, -7 MOD -3 = -1 CLRA SUB L LD L,A LD A,00H SBC A,H LD H,A RET $99 POP HL ; return_address PUSH DE ; leave dividend on stack... JP DIVZER ; ...and bomb. ;***** Word comparisons. pop b; pop a; push (a b) EQUI ; Compare for = POP DE POP HL LD A,L SUB E JP NZ,PSHFLS LD A,H SBC A,D JP Z,PSHTRU PSHFLS LD HL,0000H PUSH HL JP BACK GEQI ; Compare for >= POP DE POP HL GEQ0 LD A,D XOR H JP M,GEQ1 LD A,L SUB E LD A,H SBC A,D JP P,PSHTRU JP PSHFLS GEQ1 AND H JP P,PSHTRU JP PSHFLS GTRI ; Compare for > POP DE POP HL GTR0 LD A,D XOR H JP M,GEQ1 LD A,E SUB L LD A,D SBC A,H JP C,PSHTRU JP PSHFLS NEQI ; Compare for <> POP DE POP HL LD A,L SUB E JP NZ, PSHTRU LD A,H SBC A,D JP Z,PSHFLS PSHTRU LD HL,0001H PUSH HL JP BACK LEQI ; Compare for <= POP HL POP DE JP GEQ0 LESI ; Compare for < POP HL POP DE JP GTR0 ;***** Comparisons of complex things ; Beware that many comparisons work only because compiler restricts you ; to = and <> on certain types. ; The opcode tells what relation is being tested ; the next byte indicates the type of the things being compared ; if arrays are being compared, the next GBDE is the array size ; Tests allowed... ; Boolean: all relations. stuff is on the stack. ; Real: all relations. stuff is on the stack. ; Set: =, <>, <= (subset), >= (superset). stuff is on the stack. ; String: all relations. pointers to stuff are on stack. ; Arrays and records: =, <>. pointers to stuff on stack ; ; after CSETUP flags are result of a-b. CEQU CALL CSETUP JP Z,PSHTRU1 PSHFLS1 LD HL,0000H PUSH HL JP BACK1 CNEQ CALL CSETUP JP Z,PSHFLS1 PSHTRU1 LD HL,0001H PUSH HL JP BACK1 CGTR CALL CSETUP JP C,PSHFLS1 JP NZ,PSHTRU1 JP PSHFLS1 CLEQ CALL CSETUP JP C,PSHTRU1 JP NZ,PSHFLS1 JP PSHTRU1 CLSS CALL CSETUP JP C,PSHTRU1 JP PSHFLS1 CGEQ CALL CSETUP JP C,PSHFLS1 JP PSHTRU1 ; Find out the type of things being compared, jump to ; proper routine which follows the compare stuff and set flags. CSETUP LD A,(BC) ; A := type of stuff to compare INC BC SAVIPC LD E,A ; branch off to proper routine LD D,00H LD HL,CMPTBL ADD HL,DE LD E,(HL) INC HL LD D,(HL) EX DE,HL JP (HL) CMPTBL .EQU $-2 .WORD REALC .WORD STRGC .WORD BOOLC .WORD POWRC .WORD BYTEC .WORD WORDC STRGC ; Lexicographic string compare ; Compare up to min(length(a), length(b)). if still equal, ; compare sizes LENA .EQU BYTE1 POP HL POP DE EX (SP),HL EX DE,HL ; HL = ^b, DE = ^a, (SP) = return_address ; See if either HL or DE (but not both at the same time) is ; really a single char...handle as in SAS LD A,H TSTA JP NZ,$03 ; HL is a disguised character ! LD A,L LD (LTSTRNG+1),A LD HL,LTSTRNG JP $06 $03 LD A,D TSTA JP NZ,$06 ; DE is a char LD A,E LD (LTSTRNG+1),A LD DE,LTSTRNG $06 LD C,(HL) ; C := length(b) LD A,(DE) ; B := (LENA) := length(a) LD (LENA),A LD B,A CP C ; B := min(length(a), length(b)) JP C,$10 LD B,C LD A,C $10 TSTA ; check for min = 0 JP Z,$30 $20 INC HL INC DE LD A,(DE) CP (HL) RET NZ DJNZM $20 $30 ; Strings are equal up to length of smallest, so compare sizes LD A,(LENA) CP C RET BYTEC ; Byte array compare CALL GBDE ; DE := number of bytes to compare SAVIPC LD C,E LD B,D JP GPTRS WORDC ; Word array or multiple word record compare CALL GBDE ; DE := number of words to compare SAVIPC EX DE,HL ; DE := # bytes to compare ADD HL,HL LD C,L LD B,H GPTRS ; Set DE := ^a, HL := ^b POP HL POP DE EX (SP),HL EX DE,HL JP SWEQ ; Scan while equal. ; DE = ^b, HL = ^a, BC = # bytes to compare ; Scans until unequal comparison or compared all the bytes. ; Flags left set by last comparison .IF Z80 SWEQ1 INC DE SWEQ LD A,(DE) CPI JP PO,$20 ; if Parity Odd, BC = 0 and things ; are equal throughout JP Z,SWEQ1 ; if Zero, both bytes were equal $20 DEC HL ; set flags as result of last compare CP (HL) RET .ENDC .IF ~Z80 SWEQ CALL NEGBC ; BC := -BC $10 LD A,(DE) CP (HL) RET NZ INC HL INC DE INC C ; loop control JP NZ,$10 INC B JP NZ,$10 CLRA ; equal, so set flags accordingly RET .ENDC BOOLC ; Boolean compare. Only look at bit 0. POP HL ; HL := a, DE := b POP DE EX (SP),HL LD A,E ; get low bit of b AND 01H LD E,A LD A,L ; same for a AND 01H CP E RET NEGBC CLRA SUB C LD C,A LD A,00H SBC A,B LD B,A RET ; End-of-File ARITH .INCLUDE Z8080:SET1.TEXT .IF ~LSTSET .NOLIST .ELSE .LIST .ENDC ;Copyright (c) 1978 ; by the Regents of the University of California, San Diego ; start of file SET1 ;************************************************ ;*************** Set arithmetic ***************** SETUP ; routine to give needed information about sets on ; stack to INT, DIF, and UNI set operators. ; before ------------------------------------------------------------- ; ! ret ! szb ! set_b ! sza ! set_a ! rest of stack ; ------------------------------------------------------------- ; ! ; SP ; ; after ------------------------------------------------------------- ; ! set_b ! sza ! set_a ! rest of stack ; ------------------------------------------------------------- ; ! ! ! ; SP (NEWSP) HL ; ; B = szb, A = sza SAVIPC POP HL ; return_address EX (SP),HL ; HL := szb LD B,L ; B := szb INC HL ; skip over return_addr on stack ADD HL,HL ; HL := ^sza ADD HL,SP LD A,(HL) ; A := sza LD (NEWSP),HL ; keep future SP around INC HL INC HL RET INT ; Set intersection. AND set_b into set_a, then zero-fill ; set_a if sza>szb CALL SETUP SUB B ; B := min(sza,szb), C := max(sza-szb, 0) JP NC,$10 ADD A,B LD B,A CLRA $10 LD C,A LD A,B ; if min(sza,szb)=0, skip intersection loop TSTA JP Z,$30 $20 POP DE ; intersection loop LD A,E AND (HL) LD (HL),A INC HL LD A,D AND (HL) LD (HL),A INC HL DJNZM $20 $30 LD A,C TSTA ; if sza <= szb, no zero-fill JP Z,$50 LD B,A CLRA $40 LD (HL),A INC HL LD (HL),A INC HL DJNZM $40 $50 LD HL,(NEWSP) LD SP,HL JP BACK1 DIF ; Set difference. AND (NOT set_b) into set_a. CALL SETUP CP B ; B := min(sza,szb) JP NC,$10 LD B,A $10 LD A,B TSTA JP Z,$30 $20 POP DE ; difference loop LD A,E CPL AND (HL) LD (HL),A INC HL LD A,D CPL AND (HL) LD (HL),A INC HL DJNZM $20 $30 LD HL,(NEWSP) LD SP,HL JP BACK1 UNI ; Set union CALL SETUP CP B ; decide what kind of union to do... JP C,$30 LD A,B ; Uniona. Union set_b into set_a. TSTA JP Z,$20 $10 POP DE ; Uniona loop. LD A,E OR (HL) LD (HL),A INC HL LD A,D OR (HL) LD (HL),A INC HL DJNZM $10 $20 LD HL,(NEWSP) LD SP,HL JP BACK1 $30 ; Unionb. Szb>sza, so union set_a into set_b, then move set_b ; up to newly created top of stack LD C,A ; C := sza PUSH BC ; push szb EX DE,HL ; DE := ^set_a LD HL,0002H ; HL := ^set_b ADD HL,SP LD B,C LD A,B TSTA JP Z,$50 $40 LD A,(DE) ; Unionb loop. OR (HL) LD (HL),A INC DE INC HL LD A,(DE) OR (HL) LD (HL),A INC DE INC HL DJNZM $40 $50 ; DE = ^just past set_a LD HL,(NEWSP) ; HL := ^just past set_b POP BC ; szb is number of words to move LD C,B ; C := result_set size $60 DEC HL ; move loop. DEC DE LD A,(HL) LD (DE),A DEC HL DEC DE LD A,(HL) LD (DE),A DJNZM $60 ; DE = ^result_set EX DE,HL LD SP,HL PUSH BC JP BACK1 POWRC ; set compares. very gross. ; (see SETUP below for picture of two sets on a stack) ALEQB .EQU BYTE1 ; boolean filled by PCSETUP POP HL ; junk return address - each comparison will ; push a result ; find what rel_op to do DEC BC ; A := p-machine op that got us here DEC BC LD A,(BC) ADD A,A ; A := index into PCTBL SUB 5EH LD E,A ; HL := ^jump address LD D,00H LD HL,PCTBL ADD HL,DE LD E,(HL) ; HL := jump address INC HL LD D,(HL) EX DE,HL JP (HL) PCTBL .WORD PCEQL .WORD PCGEQ .BLOCK 6 .WORD PCLEQ .BLOCK 4 .WORD PCNEQ ; Routines used in comparisons of sets... PCSETUP ; return HL = ^set_a, SP = ^set_b ; B = min(sza,szb), C = szb-sza, Zero flag set if B = 0 POP HL ; return_address EX (SP),HL ; B := HL := szb LD B,L INC HL ; HL := ^sza ADD HL,HL ADD HL,SP LD C,(HL) ; C := sza INC HL ; HL := ^set_a INC HL PUSH HL LD E,C ; HL := newsp LD D,00H ADD HL,DE ADD HL,DE LD (NEWSP),HL POP HL ; HL := ^set_a again LD E,0 ; aleqb := false LD A,B ; A := szb-sza SUB C JP C,$10 ; B := min(sza, szb) INC E ; aleqb := true LD B,C $10 LD C,A ; C := szb-sza LD A,E ; Store aleqb LD (ALEQB),A LD A,B ; Zero flag := (B = 0) TSTA RET ZERCHKA ; insure rest of set_a is zeroes POP DE ; return_address LD SP,HL CLRA ; negate C, cause it tells how much set_b is SUB C ; bigger than set_a LD C,A EX DE,HL JP ZER0 ZERCHKB ; insure rest of set_b is zeroes ; SP = ^place to start, C = # of words to check ; return C = 1 (yep, only zeroes), or 0 (nope) RETADR2 .EQU WORD1 POP HL ZER0 LD (RETADR2),HL LD A,C ; need to check anything ? TSTA JP Z,$20 ; yep... LD B,C ; ...set up loop control... LD C,00H ; ...and assume we're not going to make it CLRA $10 POP DE OR E OR D JP NZ,$30 DJNZM $10 $20 LD C,01H ; we did make it...set is zero filled $30 LD HL,(RETADR2) JP (HL) PCEQSN ; return c = 1 if set_a = set_b, C = 0 otherwise POP HL LD (RETADR),HL CALL PCSETUP JP Z,$20 $10 POP DE LD A,E CP (HL) JP NZ,$40 INC HL LD A,D CP (HL) JP NZ,$40 INC HL DJNZM $10 $20 ; so far sets are equal. make sure larger has zeroes from here on. LD A,(ALEQB) TSTA JP NZ,$30 ; set_a is larger CALL ZERCHKA JP $50 $30 ; set_b is larger CALL ZERCHKB JP $50 $40 LD C,00H $50 LD HL,(RETADR) JP (HL) ; At last, the comparison operators reached via PCTBL PCEQL CALL PCEQSN JP PCRSLT PCNEQ CALL PCEQSN LD A,01H ; want NOT C as result XOR C LD C,A PCRSLT LD HL,(NEWSP) LD SP,HL LD B,00H PUSH BC JP BACK1 PCLEQ ; see if set_a subset_of set_b, ie., (set_a - set_b) = null_set CALL PCSETUP JP Z,$20 $10 POP DE LD A,E CPL AND (HL) JP NZ,PCFALSE INC HL LD A,D CPL AND (HL) JP NZ,PCFALSE INC HL DJNZM $10 $20 ; so far nothing is amiss LD A,(ALEQB) ; if set_a is bigger, zerocheck it TSTA CALL Z,ZERCHKA JP PCRSLT PCFALSE LD C,00H JP PCRSLT PCGEQ ; see if set_a superset_of set_b, ie., (set_b - set_a) = null set CALL PCSETUP JP Z,$20 $10 POP DE LD A,(HL) CPL AND E JP NZ,PCFALSE INC HL LD A,(HL) CPL AND D JP NZ,PCFALSE INC HL DJNZM $10 $20 ; everything's alright so far. check zeroes LD A,(ALEQB) ; If set_b is bigger, zerocheck it TSTA CALL NZ,ZERCHKB JP PCRSLT ; End-of-File SET1 .INCLUDE Z8080:SET2.TEXT .IF ~LSTSET .NOLIST .ELSE .LIST .ENDC ; Copyright (c) 1978 by the ; Regents of the University of California, San Diego ; start of file SET2 ;***** Set building and size adjusting SGS ; Build a singleton set, the set [i] POP DE PUSH DE PUSH DE SRS ; Build a subrange set, the set [i..j] IDIV .EQU BYTE1 JDIV .EQU BYTE1 SAVIPC ; are i,j valid ? POP DE ; DE := j POP BC ; BC := i LD A,B ; is i<0 ? TSTA JP M,$99 LD HL,0F010H ; is j >= 16*255 ? ADD HL,DE JP C,$99 LD A,E ; is ji DIV 16 DO ; BEGIN push(xx); xx := ; t := t-1 END ; xx := xx AND unbitr[i MOD 16]; t := i DIV 16 ; WHILE t >= 0 DO ; BEGIN push(xx); xx := ; t := t-1 END ; push(j DIV 16 +1) (* set size *) ; Actual code is slightly more efficient. ; In the following, ; idiv = i DIV 16, imod = 2*(i MOD 16), ; jdiv = j DIV 16, jmod = 2*(j MOD 16) ; currently BC = i, DE = j. ; Compute C := imod, B := idiv .IF Z80 LD HL,IDIV ; set up rotate digit environment LD (HL),C LD A,B RRD ; Presto chango. A = i MOD 16, (IDIV) = idiv RLA ; A := imod LD C,A LD B,(HL) ; Compute HL := BITTER+jmod ; (JDIV) := jdiv; A = jdiv LD (HL),E ; JDIV=IDIV, so HL already set up LD A,D RRD RLA ; A = jmod, (JDIV) = jdiv LD E,A LD D,00H LD A,(HL) LD HL,BITTER ADD HL,DE .ENDC .IF ~Z80 LD A,C AND 0FH RLA LD L,A ; L = imod LD A,B RLA RLA RLA RLA LD H,A ; H = 4 high bits of idiv, low 4 bits are 0 LD A,C AND 0F0H RRA RRA RRA RRA ; A = 4 low bits of idiv, high 4 bits are 0 OR H ; put 'em together LD B,A LD C,L ; Compute HL := BITTER+jmod ; (JDIV) := jdiv; A := jdiv LD A,E AND 0FH RLA LD L,A ; L = jmod LD A,D RLA RLA RLA RLA LD H,A ; H = high digits of jdiv LD A,E AND 0F0H RRA RRA RRA RRA OR H ; A = jdiv LD (JDIV),A LD H,00H LD DE,BITTER ADD HL,DE .ENDC LD E,(HL) ; DE := bitter[jmod] INC HL LD D,(HL) SUB B ; A := jdiv-idiv ; WHILE t > i DIV 16 stuff... JP Z,$30 PUSH DE LD DE,0FFFFH JP $20 $10 PUSH DE $20 DEC A JP NZ,$10 $30 ; DE := DE AND unbitter[imod] LD A,B ; save idiv for a second LD B,00H LD HL,UNBITR ADD HL,BC LD B,A ; restore idiv LD A,E AND (HL) LD E,A INC HL LD A,D AND (HL) LD D,A ; WHILE t >= 0 DO stuff... PUSH DE LD DE,0000H LD A,B TSTA JP Z,$50 $40 PUSH DE DJNZM $40 $50 LD A,(JDIV) ; push set size INC A LD L,A LD H,00H PUSH HL JP BACK1 $90 LD HL,0000H ; push the null set (set_size = 0) PUSH HL JP BACK1 $99 LD HL,0000H PUSH HL JP INVNDX UNBITR .WORD 0FFFFH .WORD 0FFFEH .WORD 0FFFCH .WORD 0FFF8H .WORD 0FFF0H .WORD 0FFE0H .WORD 0FFC0H .WORD 0FF80H .WORD 0FF00H .WORD 0FE00H .WORD 0FC00H .WORD 0F800H .WORD 0F000H .WORD 0E000H .WORD 0C000H .WORD 08000H ADJ ; Fix the size of the set on the stack SVDIF .EQU WORD1 ; Algorithm... ; szfinal := GETBYTE; pop(szorig); ; .IF szfinal <> szorig THEN ; .IF szorig > szfinal THEN ; BEGIN (* crunch set *) ; dst := SP+szorig-1; src := SP+szf-1; ; THRU szfinal DO ; BEGIN dst^ := src^; dst := dst-1; src := src-1 END; ; SP := dst+1 ; END ; ELSE (* expand set *) ; BEGIN ; src := SP; dst := SP-(szfinal-szorig); SP := dst; ; THRU szorig DO ; BEGIN dst^ := src^; dst := dst+1; src := src+1 END; ; THRU (szfinal-szorig) DO BEGIN dst^ := 0; dst := dst+1 END ; ; END ; NOTE: no zero checking on the part of the set that is crunched out. .IF Z80 LD A,(BC) INC BC LD L,A LD H,00H ADD HL,HL EX DE,HL POP HL ADD HL,HL ; HL := szorig (in bytes) SUBHLDE ; compare szorig-szfinal JP Z,BACK ADD HL,DE SAVIPC JP M,$10 ; Crunch set LD C,E ; BC := # bytes to move LD B,D ADD HL,SP ; Compute dst := sp+szorig-1 DEC HL EX DE,HL ; DE := dst ADD HL,SP ; Compute src := sp+szfinal-1 DEC HL ; HL := src LDDR ; move the stuff EX DE,HL ; and cut back the stack INC HL LD SP,HL JP BACK1 $10 ; Expand set LD C,L ; BC := # bytes to move LD B,H SUBHLDE LD (SVDIF),HL ; (SVDIF) := -(szfinal-szorig) EX DE,HL LD HL,0000H ADD HL,SP EX DE,HL ; DE := sp, HL := -(szfinal-szorig) ADD HL,SP ; HL := sp-(szfinal-szorig) LD SP,HL EX DE,HL ; all set up for transfer LD A,C ; but skip if szorig=0 OR B JP Z,$20 LDIR ; move stuff $20 LD A,(SVDIF) ; set BC := szfinal-szorig CPL LD C,A LD A,(SVDIF+1) CPL LD B,A INC BC LD A,00H ; Do zero filling... LD (DE),A LD L,E ; Block move trickiness LD H,D INC DE DEC BC LDIR JP BACK1 .ENDC .IF ~Z80 ; for 8080, things are done in words rather than bytes LD A,(BC) ; A := szfinal INC BC POP HL ; L := szorig CP L ; szfinal-szorig JP Z,BACK PUSH HL ; so it doesn't get messed up SAVIPC POP HL JP NC,$10 ; Crunch the set LD B,A ; B := # words to transfer ADD HL,HL ; HL := sp+szorig (dst+1) ADD HL,SP EX DE,HL ADD HL,HL ADD HL,SP ; HL = src+1, DE = dst+1, $05 DEC HL ; B = # words to transfer DEC DE LD A,(HL) LD (DE),A DEC HL DEC DE LD A,(HL) LD (DE),A DEC B JP NZ,$05 EX DE,HL ; now fix up SP LD SP,HL JP BACK1 $10 ; Expand the set LD B,L ; B := # words to move SUB L LD C,A ; C := # words to zero fill CPL INC A ; A := -(szfinal-szorig) LD L,A ; HL := A, sign extended LD H,0FFH ADD HL,HL ADD HL,SP ; HL = SP-(szfinal-szorig) EX DE,HL LD HL,0000H ADD HL,SP EX DE,HL ; DE := SP LD SP,HL LD A,B ; check for szorig=0 TSTA JP Z,$30 $20 LD A,(DE) ; move stuff LD (HL),A INC DE INC HL LD A,(DE) LD (HL),A INC DE INC HL DEC B JP NZ,$20 $30 LD A,00H ; now do zero filling $40 LD (HL),A INC HL LD (HL),A INC HL DEC C JP NZ,$40 JP BACK1 .ENDC INN ; ------------------------------------------------- ; ! sza ! set_a ! i ! rest of stack ; ------------------------------------------------- ; is i in set_a ? SAVIPC POP HL ; E := sza LD E,L ADD HL,HL ADD HL,SP ; HL = ^i LD C,(HL) ; BC := i INC HL LD B,(HL) INC HL PUSH HL ; (SP) := ^rest of stack LD HL,0F010H ; is i >= 16*255 or < 0 ? ADD HL,BC JP C,$99 ; convert i to word and bit within word ; B := word, C := bit .IF Z80 LD HL,IDIV LD (HL),C LD A,B RRD ; A = i mod 16, (IDIV) = i div 16 LD B,(HL) LD C,A LD A,B .ENDC .IF ~Z80 ; drag... LD A,C AND 0FH LD L,A ; L = i mod 16 LD A,B RLA RLA RLA RLA LD H,A LD A,C ; H = i div 16, high 4 bits AND 0F0H RRA RRA RRA RRA OR H LD B,A LD C,L .ENDC CP E ; is set big enough to contain i ? JP NC,$20 LD A,C ; DE := bit offset in byte AND 07H LD E,A LD D,00H LD HL,INMASK ADD HL,DE ; HL = ^INMASK[i mod 8] LD A,(HL) PUSH AF ; save mask for a bit LD L,B ; HL := ^needed byte of set_a LD H,00H INC HL INC HL ; take care of extra 2 word on stack ADD HL,HL LD A,C ; now add 1 to address if in high byte of word AND 08H ; is bit 3 of i mod 16 on ? JP Z,$10 INC HL $10 ADD HL,SP POP AF AND (HL) ; AND that byte and the mask JP Z,$20 ; decide what to do now POP HL LD SP,HL LD HL,0001H PUSH HL JP BACK1 $20 POP HL LD SP,HL LD HL,0000H PUSH HL JP BACK1 $99 POP HL LD SP,HL LD HL,0000H PUSH HL ; after cleaning up stack... JP INVNDX ; bomb the program INMASK .BYTE 01H .BYTE 02H .BYTE 04H .BYTE 08H .BYTE 10H .BYTE 20H .BYTE 40H .BYTE 80H ; End-of-File SET2 .INCLUDE Z8080:FPL.TEXT .IF ~LSTFP .NOLIST .ELSE .LIST .ENDC ;Copyright (c) 1978 ; by the Regents of the University of California, San Diego ; Beginning of file FPL ; Floating point stuff...including basic stuff like the four math ; functions, fix, and float; and much more esoteric stuff, like ; transcendental functions. All routines of any general interest ; are callable. ; Hopefully in the near future there will be an arithmetic vector table, ; so you people adding assembly procedures to your system will ; be able to make use of all this wonderful software. ; Naming conventions used throughout the floating point package... ; FPCa Floating point constant a. ; FPMa Floating point macro a. Some of these macros leave ; well-specified stuff in registers. ; FPFa Floating point function a. Takes argument(s) on tos, ; leaves result on tos, and also in EDCB (except for ; FPFFIX, FPFDOUB, FPFHALV). ; FPLa Floating point low level function. Not necessarily ; directly callable, and probably not of interest to ; the user. ; FPGa Floating point global variable a. ; aLb Floating point local variable b for function a. ; FPRa Floating point relational function a. Returns ; Z = false, NZ = true (not yet meaningful). ;***************** BASIC FLOATING POINT ARITHMETIC *************; ; Based on an 8080 floating point package by John Lamping ; Numbers are four byte quantities represented as... ; [exp] [sabc v] [w x] [y z] ; s, a, b, c are bits, v, w, x, y, z are hex digits. ; Exponent is biased by 128. Mantissa is always normalized, and includes ; "invisible" bit just in front of a. ; If exp = 0, number value is zero. ; number value = (1-2*s) * .1abcvwxyz * 2^(exp-128) ; Currently only simple rounding is used...true rounding to be implemented ; sometime in the future. ; Any operation causing overflow or underflow will store a 01H into (FPERROR) ; (I know error handling in these low-level routines could be simplified, ; but error-protocol was changed after this stuff was adapted to be ; used in the P-machine, and it was easier to put in small fixes.) FPLSETUP ; for fpadd, fpmul, fpdiv, fpsub ; set HL = ^b, DE = ^a, A = # bytes of operands ; stack is ret. addr. in fp. | ret. addr. | b | a LD HL,0004H ADD HL,SP LD E,L LD D,H INC E INC DE INC E INC DE LD A,8 CLRCF RET FPFADD CALL FPLSETUP PUSH AF ; save stack cutting info and error info. LD A,02H ; indicate 'add' JP FPLSUM FPFSUB CALL FPLSETUP PUSH AF LD A,7FH ; indicate 'subtract' FPLSUM LD B,A ; save add/subtract info LD A,(DE) ; A := arg1.exp - arg2.exp SUB (HL) JP NC,$10 EX DE,HL ; arg2.exp larger, so switch args... INC B ; ...indicate so in add/subtract info... NEGA ; ...and negate exp diff. $10 LD C,A ; save exp diff LD A,(HL) ; is arg2 = 0 ? TSTA JP NZ,$20 INC C ; yes. is arg1.exp = arg2.exp (= 0) ? DEC C JP Z,FPLZERO ; if so, result is 0. LD C,25 ; only arg2 zero, so set exp diff ; past floating point precision. $20 PUSH DE ; save addr of big exp INC HL ; move to mantissas INC DE ; Compute result sign. If add, sign of mantissa with larger exp. ; If non-swapped subtract, sign of larger exp mantissa, else CPL ; of sign of larger exp mantissa. Done by (swapped XOR sign of ; larger mantissa). LD A,(DE) LD E,A ; save sign of larger exp mantissa XOR B RLCA ; put computed result sign in bit 0 LD D,A ; and save it. ; Compute difference of signs. if add, XOR of signs; if subtract, ; CPL of XOR of signs. LD A,E ; sign of larger exp mantissa INC B XOR B XOR (HL) XOR D ; merge with result sign AND 80H XOR D LD E,A ; save it LD A,(HL) ; Load mantissa of smaller arg into BCDE OR 80H ; Put in hidden bit LD B,A LD A,C INC HL LD C,(HL) INC HL LD D,(HL) LD H,E ; move sign information LD E,00H ; clear rest of mantissa ; position smaller mantissa CP 26 ; limit shifts to 25 JP C,$30 LD A,25 $30 SUB 8 ; at least 8 shifts ? JP C,$40 LD E,D ; yep. shift registers. LD D,C LD C,B LD B,00H JP $30 ; try that trick again. $40 ADD A,8 LD L,A JP Z,$60 $50 ; shift mantissa right one place .IF Z80 SRL B RR C RR D RR E .ENDC .IF ~Z80 CLRCF LD A,B RRA LD B,A LD A,C RRA LD C,A LD A,D RRA LD D,A LD A,E RRA LD E,A .ENDC DEC L ; done shifting ? JP NZ,$50 $60 INC H ; test sign diff (P signs same, M signs differ) DEC H EX (SP),HL ; save result sign, get ^big arg LD A,(HL) ; A := answer exp EX (SP),HL ; Store LD L,A ; sign EX (SP),HL ; and exp INC HL ; point HL to low mantissa byte of big arg INC HL INC HL JP M,$70 ; jump if signs were different ; Do Addition. LD A,D ; Add mantissas ADD A,(HL) LD D,A DEC HL LD A,C ADC A,(HL) LD C,A DEC HL LD A,(HL) RLA ; turn on hidden bit SCF RRA ADC A,B LD B,A POP HL ; get sign, exp JP NC,FPLRND ; gotta shift down one place .IF Z80 RR B RR C RR D RR E .ENDC .IF ~Z80 RRA LD B,A LD A,C RRA LD C,A LD A,D RRA LD D,A LD A,E RRA LD E,A .ENDC INC L ; Increment result exp, and JP FPLRND ; go round result ; Do subtraction $70 CLRA ; subtract lowest byte from 0 SUB E LD E,A LD A,(HL) SBC A,D LD D,A DEC HL LD A,(HL) SBC A,C LD C,A DEC HL LD A,(HL) RLA ; turn on hidden bit SCF RRA SBC A,B LD B,A FPLSUMX JP NC,FPLNRM ; if subtracted smaller from bigger normalize POP HL ; blew it. change answer sign. INC H PUSH HL CLRA LD H,A SUB E ; and complement mantissa (subtracted LD E,A ; larger from smaller) LD A,H SBC A,D LD D,A LD A,H SBC A,C LD C,A LD A,H SBC A,B LD B,A JP FPLNRM FPFMUL CALL FPLSETUP PUSH AF ; save stack cutback, error info LD A,(DE) ; load exp's LD B,A LD C,(HL) TSTA ; if either arg zero, result is zero JP Z,FPLZERO INC C DEC C JP Z,FPLZERO INC DE ; move pointers to mantissas INC HL LD A,(DE) ; Compute answer sign (in bit zero) XOR (HL) RLCA PUSH AF ; and save it LD A,B ; get exp sum DEC A ADD A,C ; should be between 80 and 17F (hex) POP BC ; get back sign info JP M,$10 ; check exp sum out JP NC,FPLUND JP $20 $10 JP C,FPLOVRX $20 ADD A,81H ; everything's cool. bias exp sum. LD C,A ; and save with sign info PUSH BC LD A,(DE) ; load first two bytes of arg1 (putting in OR 80H ; hidden bit) and save on stack LD B,A INC DE LD A,(DE) LD C,A PUSH BC INC DE ; load last byte of arg1 LD A,(DE) LD B,A LD A,(HL) ; load E,H,L with arg two mantissa OR 80H INC HL LD D,(HL) INC HL LD E,(HL) EX DE,HL LD E,A LD C,8 ; Set up PUSH BC ; first multiplier EX (SP),HL ; and count LD BC,0000 ; Clear answer LD D,B ; Main Multiply Loop ; BCD holds 24 bit accumulated sum, E (SP) is multiplicand ; L is loop count, (SP+2) is high order bytes of multiplier ; H is low order byte of multiplier and extra bits of ; precision of sum $30 LD A,H ; get multiplier and previous shift outs $40 RRA ; get low bit, save previous shift out LD H,A ; put multiplier back LD A,B ; get B in case no add EX (SP),HL ; get back multiplicand JP NC,$50 ; jump if no add necessary LD A,D ; add multiplicand to acculumated sum ADD A,L LD D,A LD A,C ADC A,H LD C,A LD A,B ADC A,E $50 ; shift sum right one bit RRA LD B,A .IF Z80 RR C RR D ; carry on if bit shifted out .ENDC .IF ~Z80 LD A,C RRA LD C,A LD A,D RRA LD D,A .ENDC EX (SP),HL ; get multiplier, count DEC L JP NZ,$30 LD A,H ; save previous carries out POP HL ; get more multiplier EX (SP),HL PUSH AF ; save carries LD A,H ; Check for done - we are if high bytes of OR L ; multiplier are zero JP Z,$60 POP AF ; junk carry stuff LD A,L ; shift to next byte LD L,H LD H,00H EX (SP),HL ; save shifted bytes PUSH HL ; save multiplicand LD L,8 ; set count JP $40 $60 POP AF ; get carries out POP HL ; junk multiplicand RRA ; put carries into E LD E,A FPLMULX POP HL ; get sign, exp INC B ; test sign of answer DEC B JP FPLNRMX ; normalize it FPFDIV CALL FPLSETUP PUSH AF ; save stack cutback, error info LD A,(DE) ; get exp1 LD C,A INC DE ; get arg1 sign in case div by zero LD A,(DE) RLCA LD B,A LD A,(HL) ; get arg2.exp TSTA ; check for zero JP Z,FPLOVRX ; divide by zero INC C ; check for dividend zero DEC C JP Z,FPLZERO LD B,A ; save arg2.exp LD A,(DE) ; compute and save result sign INC HL XOR (HL) RLCA ; put in bit 0 PUSH AF LD A,C ; get exp diff SUB B POP BC ; get back result sign again JP M,$10 ; check for over or underflow JP C,FPLUND JP $20 $10 JP NC,FPLOVRX $20 ADD A,81H ; bias exponent LD C,A ; save future exp with sign info PUSH BC LD BC,0000 ; set up answer PUSH BC INC C ; put 1 in low bit so know when we have ; shifted 8 times PUSH BC PUSH HL ; save ^arg2 EX DE,HL ; Load E,H,L with arg1.mantissa LD A,(HL) OR 80H ; put in hidden bit INC HL LD D,(HL) INC HL LD E,(HL) EX DE,HL LD E,A EX (SP),HL ; load B,C,D with arg2.mantissa LD A,(HL) OR 80H LD B,A INC HL LD C,(HL) INC HL LD D,(HL) POP HL ; Main Divide Loop ; EHL remainder, BCD divisor, (SP) (SP+2) quotient so far $30 JP C,$40 ; jump if carry shifted out LD A,B ; compare magnitudes CP E JP C,$40 JP NZ,$50 LD A,C CP H JP C,$40 JP NZ,$50 LD A,L CP D CCF ; so we remember what if we subtracted JP NC,$50 $40 LD A,L ; subtract divisor from remainder SUB D LD L,A LD A,H SBC A,C LD H,A LD A,E SBC A,B LD E,A SCF ; so we remember we subtracted $50 EX (SP),HL ; Record if we subtracted LD A,L RLA LD L,A JP NC,$70 ; Jump if byte not full EX DE,HL ; Get some elbow room PUSH HL LD HL,0005 ; Point to most significant result byte ADD HL,SP LD A,(HL) ; If non-zero we are done TSTA JP NZ,$80 DEC HL ; move answer bytes up one byte LD A,(HL) LD (HL),D INC HL LD (HL),A LD D,E LD E,01 ; set up 8 more loops TSTA ; if high byte now non-zero, only need JP Z,$60 ; two more loops for 26-bit precision. (24 for LD E,40H ; answer, 1 if high bit 0, 1 for rounding) $60 POP HL ; give back elbow room EX DE,HL $70 EX (SP),HL ; get back remainder ADD HL,HL ; shift remainder left one bit LD A,E RLA LD E,A JP $30 ; go for it again $80 POP BC ; junk remainder POP BC POP BC ; get rest of answer LD A,E ; put 25th and 26th bits in high part RRCA ; of E RRCA LD E,A JP FPLMULX ; go normalize answer FPFFLOAT ; convert integer tos to fp number POP HL ; return_address POP BC ; arg to float PUSH HL XOR A ; tell FPSTOR to cut stack back zero bytes, PUSH AF ; and that no error has occurred. LD DE,0090H ; set sign PUSH DE ; and exponent LD E,D ; clear rest of mantissa LD A,B ; set carry and sign flags if sign negative CLRCF RLA JP FPLSUMX ; negate if necessary, then normalize FPFFIX POP HL ; return_address ; load high bytes of mantissa into BC, sign into D, exp into E POP DE ; D := high byte mantissa, E := exp LD A,D OR 80H ; turn on hidden bit POP BC ; C := middle byte mantissa LD B,A LD A,E ; (only need 16 bits of man) if EXP >= 90H SUB 90H JP C,$30 ; Overflow! check sign bit of answer INC D DEC D JP M,$10 LD BC,7FFFH ; load maxint. JP $20 $10 LD BC,8000H ; load -maxint-1 $20 PUSH BC LD A,1 ; signify error LD (FPERROR),A JP (HL) ; and return $30 CP -16 ; max of 16 shifts JP NC,$40 LD A,-16 $40 LD E,A ; save shift count $50 ; shift mantissa right one bit .IF Z80 SRL B RR C .ENDC .IF ~Z80 CLRCF LD A,B ; shift mantissa down RRA LD B,A LD A,C RRA LD C,A .ENDC INC E JP NZ,$50 INC D ; test result sign DEC D JP P,$70 CLRA ; negate result SUB C LD C,A LD A,00H SBC A,B LD B,A $70 PUSH BC ; push answer JP (HL) ; and return FPLNRM POP HL ; get sign info and exponent JP NZ,FPLNRMX ; jump if semi-normalized (high byte non-zero) LD A,E ; check mantissa for zero OR D OR C JP Z,FPLZERO LD A,L ; get exp $10 SUB 9 ; exp big enough to move 8 bits? JP C,FPLUND INC A LD B,C ; shift mantissa one byte LD C,D LD D,E LD E,00 INC B ; check new high byte DEC B JP Z,$10 LD L,A ; put back exp FPLNRMX JP M,FPLRND $20 DEC L ; decr exp JP Z,FPLUND ; Shift mantissa lift one bit .IF Z80 SLA E RL D RL C RL B .ENDC .IF ~Z80 EX DE,HL ADD HL,HL EX DE,HL LD A,C RLA LD C,A LD A,B ADC A,B LD B,A .ENDC JP P,$20 FPLRND LD A,E ; jump if round up unnecessary RLA JP NC,FPLSIGN INC D JP NZ,FPLSIGN INC C JP NZ,FPLSIGN INC B JP NZ,FPLSIGN LD B,80H INC L ; bump up exp JP FPLSIGN FPLZERO CLRA ; load a zero JP FPLSET ; and propagate it FPLOVRX LD H,B ; position sign info FPLOVR LD A,0FFH JP FPLABN FPLUND CLRA FPLABN POP HL ; indicate error INC L PUSH HL LD B,A ; propagate A through mantissa... FPLSET LD C,A LD D,A LD L,A ; and exp TSTA ; see if we just put in zero's JP Z,FPLSTOR FPLSIGN INC L ; last chance for overflow DEC L JP Z,FPLOVR LD A,H ; set answer sign INC A RRCA AND 80H XOR B FPLSTOR ; result is LACD. put into a good format (ie. EDCB), cut the stack ; back, and push result LD B,D LD D,A LD E,L POP HL ; get cutback and error info EX (SP),HL LD (RETADR),HL POP HL LD A,L AND 01H ; junk all the high bits..they don't count LD L,A LD A,(FPERROR) ; flip error on if error occured OR L LD (FPERROR),A LD L,H ; calculate new tos LD H,00H ADD HL,SP LD SP,HL PUSH BC PUSH DE LD HL,(RETADR) JP (HL) ; End of file FPL .INCLUDE Z8080:FPI.TEXT .IF ~LSTFP .NOLIST .ELSE .LIST .ENDC ;Copyright (c) 1978 ; by the Regents of the University of California, San Diego ; Beginning of file FPI ; ************ Macros... .MACRO FPMPUSH ; push the fp # residing at addr given LD HL,(%1 + 2) PUSH HL LD HL,(%1) PUSH HL .ENDM .MACRO FPMPOP ; pop the fp tos into addr given POP HL LD (%1),HL POP HL LD (%1 + 2),HL .ENDM .MACRO FPMSAVE ; save to fp tos into addr given POP DE ; leaves fp on tos, and in LHED POP HL LD (%1 + 2),HL EX DE,HL LD (%1),HL PUSH DE PUSH HL .ENDM ; adjust stack which contains a ret addr ; and one fp. leave fp in LHED. If addr ; specified put arg into it. If "junk" ; specified (only legal if addr given) ; then don't leave fp on stack. .MACRO FPMADJ ; Adjust stack, which contains a ret. addr. .IF "%1" = "" ; and one fp. Leave fp in LHED. If addr. POP BC ; passed to macro stick fp in it, too. If POP HL ; "junk" passed (only legal is addr. is POP DE ; given) then don't leave fp as tos, but PUSH BC ; toss it away. PUSH DE PUSH HL .ELSE POP BC POP DE POP HL PUSH BC LD (%1 + 2),HL EX DE,HL LD (%1),HL .IF "%2" <> "JUNK" PUSH DE PUSH HL .ENDC .ENDC .ENDM .MACRO FPMDUP ; duplicate tos .IF "%1" = "LHED" PUSH DE PUSH HL .ENDC .IF "%1" = "EDCB" PUSH DE PUSH HL .ENDC .IF "%1" = "" POP HL POP DE PUSH DE PUSH HL PUSH DE PUSH HL .ENDC .ENDM .MACRO FPMFRET ; the complement to FPMADJ. leaves POP DE ; function result on stack and in EDCB, POP BC ; and returns from function POP HL PUSH BC PUSH DE JP (HL) .ENDM ;***** Floating point simple callable routines FPFNEG ; -x POP HL ; ret addr POP DE POP BC LD A,D ; get sign XOR 80H ; flip it LD D,A PUSH BC PUSH DE JP (HL) ; and get out of here (very negative vibes) FPFABS ; abs(x) POP HL ; ret addr POP DE POP BC LD A,D AND 7FH ; clear sign LD D,A PUSH BC PUSH DE JP (HL) ; we are absolutely done FPFSQR ; sqr(x: real): real FPMADJ FPMDUP LHED CALL FPFMUL FPMFRET FPFRND ; round(x: real): integer FPMADJ LD A,H ; get sign info, so know to add 0.5 AND 80H ; or -0.5 LD H,A ; construct high mantissa LD L,80H ; set up exp LD DE,0000H ; set up low order mantissa PUSH DE PUSH HL CALL FPFADD CALL FPFFIX POP DE ; can't hang around here too long POP HL PUSH DE JP (HL) FPFINV ; computes 1/x POP HL ; ret addr. POP DE POP BC PUSH HL LD HL,0 ; low mantissa of 1.0 PUSH HL LD HL,0081H ; high mantissa, sign, and exp PUSH HL PUSH BC PUSH DE CALL FPFDIV FPMFRET ; eyb-eyb FPFPOT ; pwroften(i:integer): real ; returns 10 ^ i, 0 <= i <= 38 POP DE ; ret addr POP HL ; HL := power PUSH DE LD E,L ; save a sec LD D,H LD BC,-39 ; check validity of power ADD HL,BC JP C,$99 EX DE,HL ; multiply power by 4 ADD HL,HL ADD HL,HL LD DE,TENTBL+3 ; point HL at highest byte of right number ADD HL,DE LD B,(HL) ; and put fp in EDCB DEC HL LD C,(HL) DEC HL LD D,(HL) DEC HL LD E,(HL) POP HL ; get out ret addr back PUSH BC PUSH DE JP (HL) $99 POP HL ;Mexican LD DE,0000 PUSH DE PUSH DE LD A,1 LD (FPERROR),A JP (HL) TENTBL ; power of ten table...typed in by hand. ; 1E0..1E9 .BYTE 81H, 00H, 00H, 00H, 84H, 20H, 00H, 00H .BYTE 87H, 48H, 00H, 00H, 8AH, 7AH, 00H, 00H .BYTE 8EH, 1CH, 40H, 00H, 91H, 43H, 50H, 00H .BYTE 94H, 74H, 24H, 00H, 98H, 18H, 96H, 80H .BYTE 9BH, 3EH, 0BCH, 20H, 9EH, 6EH, 6BH, 28H ; 1E10..1E19 .BYTE 0A2H, 15H, 02H, 0F9H, 0A5H, 3AH, 43H, 0B7H .BYTE 0A8H, 68H, 0D4H, 0A5H, 0ACH, 11H, 84H, 0E7H .BYTE 0AFH, 35H, 0E6H, 21H, 0B2H, 63H, 5FH, 0A9H .BYTE 0B6H, 0EH, 1BH, 0CAH, 0B9H, 31H, 0A2H, 0BDH .BYTE 0BCH, 5EH, 0BH, 6CH, 0C0H, 0AH, 0C7H, 24H ; 1E20..1E29 .BYTE 0C3H, 2DH, 78H, 0EDH, 0C6H, 58H, 0D7H, 28H .BYTE 0CAH, 07H, 86H, 79H, 0CDH, 29H, 68H, 17H .BYTE 0D0H, 53H, 0C2H, 1DH, 0D4H, 04H, 59H, 52H .BYTE 0D7H, 25H, 6FH, 0A7H, 0DAH, 4EH, 0CBH, 91H .BYTE 0DEH, 01H, 3FH, 3BH, 0E1H, 21H, 8FH, 0AH ; 1E30..1E38 .BYTE 0E4H, 49H, 0F2H, 0CDH, 0E7H, 7CH, 6FH, 80H .BYTE 0EBH, 1DH, 0C5H, 0B0H, 0EEH, 45H, 37H, 1CH .BYTE 0F1H, 76H, 84H, 0E3H, 0F5H, 1AH, 13H, 0EH .BYTE 0F8H, 40H, 97H, 0D2H, 0FBH, 70H, 0BDH, 0C7H .BYTE 0FFH, 16H, 76H, 09CH ; ********* Low level support routines used by the fp instructions FPLBEG ; used by instructions before routine called... SAVIPC ; save the ipc... FPLCBEG ; (entry point for CSP routines) CLRA ; ...and clear error flag LD (FPERROR),A RET FPLCHK ; exit point for all fp instructions and CSP's LD A,(FPERROR) TSTA JP Z,BACK1 JP FPIERR ;********** Simple fp instructions and standard procedures FLT ; float the top of stack CALL FPLBEG ; don't care about FPERROR, but need to savipc CALL FPFFLOAT JP BACK1 FLO ; float the integer under the real on top of stack REAL1 .EQU WORD1 REAL2 .EQU WORD2 CALL FPLBEG POP HL LD (REAL1),HL POP HL LD (REAL2),HL CALL FPFFLOAT LD HL,(REAL2) PUSH HL LD HL,(REAL1) PUSH HL JP BACK1 ABR ; Real absolute value CALL FPLBEG CALL FPFABS JP BACK1 ADR ; Add reals CALL FPLBEG ; saves ipc and sets FPERROR to false CALL FPFADD JP FPLCHK ; checks FPERROR and bombs if necessary SBR ; Subtract reals CALL FPLBEG CALL FPFSUB JP FPLCHK MPR ; Multiply reals CALL FPLBEG CALL FPFMUL JP FPLCHK SQR ; Square reals CALL FPLBEG CALL FPFSQR JP FPLCHK DVR ; Divide reals CALL FPLBEG CALL FPFDIV JP FPLCHK NGR ; Negate real CALL FPLBEG CALL FPFNEG JP BACK1 TNC ; truncate real and convert to integer CALL FPLCBEG ; csp fp set...doesn't do a savipc CALL FPFFIX JP FPLCHK RND ; round real CALL FPLCBEG CALL FPFRND JP FPLCHK POT CALL FPLCBEG CALL FPFPOT JP FPLCHK REALC ; compare the real numbers on the top of stack POP HL LD (RETADR),HL POP BC POP HL POP DE PUSH DE ; Compare signs LD A,D AND 80H LD D,A LD A,B AND 80H CP D JP NZ,$30 TSTA JP Z,$10 ; comparing negative numbers, so switch before comparing LD E,C LD D,B POP BC EX (SP),HL JP $20 $10 POP DE $20 ; check exps LD A,E CP C JP NZ,$40 ; high mantissa bytes LD A,D CP B JP NZ,$40 ; low two bytes POP DE LD A,E CP L JP NZ,$50 LD A,D CP H JP $50 $30 POP HL $40 POP HL $50 LD HL,(RETADR) JP (HL) ; End of file FPI .INCLUDE Z8080:NOFPT.TEXT .INCLUDE Z8080:PROC1.TEXT .IF ~LSTPROC .NOLIST .ELSE .LIST .ENDC ; Copyright (c) by Regents of the University of California, San Diego ;***************************************************************; ; PROGRAM FLOW - JUMPS AND PROCEDURE CALLS ; ;***************************************************************; ;***** Jumps ; JTAB format below...see procedure operators EFJ ; Equal false jump (jump if not equal) POP DE POP HL LD A,L SUB E JP NZ,UJP LD A,H SBC A,D JP NZ,UJP JP NOJ NFJ ; Not equal false jump (jump if equal) POP DE POP HL LD A,L SUB E JP NZ,NOJ LD A,H SBC A,D JP NZ,NOJ JP UJP FJP ; False jump POP AF ; Sneaky but quick. Carry is bit zero. JP NC,UJP NOJ INC BC JP BACK UJP ; Unconditional jump LD A,(BC) ; get jump offset INC BC TSTA ; if small then short relative jump JP M,$10 ADD A,C ; BC = BC + A LD C,A LD A,00H ADC A,B LD B,A JP BACK $10 LD HL,(JTAB) ; use offset as index in JTAB LD C,A LD B,0FFH ; BC = sign extended offset,0FFH ADD HL,BC ; HL = ^jump entry LD E,(HL) INC HL LD D,(HL) SELREL ; entry is self-relative JP BACK XJP ; Case jump ; Index is (SP) ; In the code, starting on a word boundary, ; are 3 words... ; min index for table ; max index ; else jump (point IPC here if index out of table range) ; ...and the case table jump addresses INC BC ; put HL on word boundary LD A,C AND 0FEH LD L,A LD H,B LD C,(HL) ; BC = min INC HL LD B,(HL) INC HL LD E,(HL) ; DE = max INC HL LD D,(HL) INC HL LD (IPCSAV),HL ; save addr of else jump POP HL ; get index EX DE,HL ; HL = max, DE = index, BC = min LD A,D XOR H JP M,$10 LD A,L ; decide if index too large... SUB E LD A,H SBC A,D JP P,$20 JP BACK1 $10 AND D JP P,BACK1 $20 EX DE,HL ; ...or too small. LD A,B XOR H JP P,$30 AND H JP M,BACK1 $30 SUBHLBC ; and put index-min in HL JP M,BACK1 INC HL ; take in to account else jump ADD HL,HL ; and set HL = case table[index] EX DE,HL LD HL,(IPCSAV) ADD HL,DE LD C,(HL) INC HL LD B,(HL) DEC HL SUBHLBC ; entry is negative self relative again. LD C,L LD B,H JP BACK ;***** Procedure calling and returning ; Variables used... SEGBOT .EQU TPROC ; pointer to bottom of segment RLBASE .EQU TPROC+2 ; base relocation amount REFP .EQU TPROC+4 ; pointer to relevant refcount PROCBOT .EQU TPROC+6 ; pc relative (proc) relocation amount RLDELTA .EQU TPROC+8 ; the relocation abount for the relocation ; currently being done. SEGNUM .EQU TPROC+10. ; segment # currently being called SEGTP .EQU TPROC+12. ; ^segtable entry for segment NEWSEG .EQU TPROC+14. ; new SEGP NEWJTB .EQU TPROC+16. ; new JTAB pointer ; Mark stack control word (MSCW) format: MSSP .EQU +0AH ; Caller's top of stack MSIPC .EQU +08H ; Caller's IPC (return address) MSSEG .EQU +06H ; Caller's segment (proc table) pointer MSJTAB .EQU +04H ; Caller's jtab pointer MSDYN .EQU +02H ; Dynamic link - pointer to caller's MSCW MSSTAT .EQU +00H ; Static link - pointer to parent's MSCW MSBASE .EQU -02H ; Base link (only if CBP) - pointer ; to base MSCW of caller ; Jump table (JTAB) format ; .EQU +01H ; lex level of proc ; .EQU 00H ; proc-num ENTRIC .EQU -02H ; address of entry point (self-relative) EXITIC .EQU -04H ; address of exit code (self-relative) PARMSZ .EQU -06H ; number of bytes of parameters DATASZ .EQU -08H ; number of bytes of local data segment ; -0AH to -08H-2*(# of long jumps) self-relative jump address ;Proc table (pointed to by msseg) format ; .EQU +01H ; number of procs in segment ; .EQU 00H ; seg_num ;-02H to -2*(number of procs) self-relative pointers to each procs JTAB ; Seg table (part of syscom) format: ; 00H ; unit number code for seg is on ; +02H ; block # code for seg starts at ; +04H ; segment length (in bytes) ; Operator formats: ; RBP,RNP: number of words to return (0..2) ; CBP,CGP,CLP,CIP: proc_num ; CXP: seg_num, proc_num RBP ; Return from base procedure LD HL,(MP) ; HL := old base DEC HL LD D,(HL) DEC HL LD E,(HL) EX DE,HL LD (BASE),HL ; restore previous base environment LD DE,DISP0 ADD HL,DE LD (BASED0),HL ; then fall into RNP RNP ; Return from normal procedure LD HL,(MPD0) ; DE := old sp (didn't want to index) LD E,(HL) INC HL LD D,(HL) LD A,(BC) ; A := Number of words to return ADD A,A ; Double for bytes JP Z,$20 ; No value to return LD C,A ; BC := # bytes to return LD B,00H LD HL,(MPD0) ; HL := ^last byte of where params go ADD HL,BC INC HL .IF Z80 DEC DE ; do the move LDDR INC DE ;EITHER WAY TO $20 , DE = NEW SP .ENDC .IF ~Z80 $10 LD A,(HL) DEC DE DEC HL LD (DE),A LD A,(HL) DEC DE DEC HL LD (DE),A DEC C DEC C JP NZ,$10 .ENDC $20 ; use info in MSCW to restore machine state LD HL,(MP) LD SP,HL POP HL ; junk stat link POP HL ; HL := dyn link LD (MP),HL ; new local MSCW := dyn link LD BC,DISP0 ADD HL,BC LD (MPD0),HL POP HL ; rest should be obvious LD (JTAB),HL ; well...it used to be obvious. See if current seg same as old POP HL LD A,(SEGP) CP L JP NZ,$30 LD A,(SEGP+1) CP H JP Z,$40 $30 ; it is different. Decrement refcount for current segment. PUSH HL LD HL,(SEGP) LD A,(HL) CALL DECREF ; decrements refcount for seg A POP HL $40 LD (SEGP),HL POP BC ; ipc EX DE,HL ; restore SP LD SP,HL JP BACK DECREF ; Decrements refcount for seg # A. ; if count becomes 0, return Zero flag set LD L,A LD H,0 ADD HL,HL ADD HL,HL LD BC,INTSEGT+1 ADD HL,BC LD B,(HL) DEC L LD C,(HL) DEC BC LD (HL),C INC L LD (HL),B LD A,C OR B RET STKCHK ; check for stack overflow LD HL,(NP) EX DE,HL LD HL,-60. ; leave a 30-word evaluation stack ADD HL,SP LD A,L SUB E LD A,H SBC A,D RET ; The callable routine used to build a mark stack control word... ; each actual procedure opcode uses it as a basis, then does some ; other stuff (usually setting the static chain pointer correctly). BLDXNL ; entry point for BLDMSCW if CXP is doing call POP HL ; (RETADR) := return_address LD (RETADR),HL JP BLD3 BLDMSCW ; Build a MSCW, copy down parameters, and set up proper environment ; for called procedure LD HL,(SEGP) LD (NEWSEG),HL POP HL ; (RETADR) := return_address LD (RETADR),HL XOR A ; indicate no code read in, not a CXP call PUSH AF BLD3 LD A,(BC) ; A := proc_num INC BC SAVIPC NEGA ; DE := -proc_num (need to index proc table LD E,A ; backward...segp^[-proc_num] = ^jtab) LD D,0FFH LD HL,(NEWSEG) ADD HL,DE ADD HL,DE LD E,(HL) ; DE := ^jtab INC HL LD D,(HL) ; entry is negative self-relative .IF Z80 SCF SBC HL,DE .ENDC .IF ~Z80 SCF LD A,L SBC A,E LD L,A LD A,H SBC A,D LD H,A .ENDC LD (NEWJTB),HL ; is it an assembly language proc ? LD A,(HL) TSTA JP NZ,$40 ; it is. See if CXP and take special action if necessary, ; leave BACK1 as ret address, and jump to it ! POP AF ; See if this was a CXP call TSTA JP Z,$35 ; oops. it was. this means we bumped ref pointer, but will never ; execute a nice return instruction to bump down the pointer. EX DE,HL ; save ^jtab LD HL,(SEGNUM) ; To fix, we will just zero that refcount LD H,0 ADD HL,HL ADD HL,HL LD BC,INTSEGT ADD HL,BC DEC (HL) ; just wipe out low...high should be zero EX DE,HL $35 LD DE,BACK1 PUSH DE DEC HL LD D,(HL) DEC L LD E,(HL) EX DE,HL JP (HL) $40 ; Regular procedure...now get datasz and parmsz LD DE,DATASZ ; HL := ^datasz ADD HL,DE LD E,(HL) ; DE := datasz INC HL LD D,(HL) INC HL LD C,(HL) ; BC := parmsz INC HL LD B,(HL) POP AF ; now extend stack in proper manner... JP C,$50 ; code not read in, so extend by datasz CLRA ; HL := SP-datasz SUB E LD L,A LD A,00H SBC A,D LD H,A ADD HL,SP LD SP,HL ; SP := SP-datasz EX DE,HL ; DE := ^param dest ADD HL,DE ; HL := ^params JP $60 $50 ; code was read in, so extend by parmsz+datasz EX DE,HL ; HL := datasz ADD HL,BC ; + parmsz CLRA ; HL := SP-datasz-parmsz SUB L LD L,A LD A,00H SBC A,H LD H,A ADD HL,SP LD SP,HL ; SP := SP-datasz-parmsz EX DE,HL ; DE := ^parma dest LD HL,(NEWSEG) ; HL := ^params INC HL INC HL $60 LD A,C ; see if parsz = 0 OR B JP Z,$80 ; copy the params down .IF Z80 LDIR .ENDC .IF ~Z80 CLRA ; BC := -BC SUB C LD C,A LD A,00H SBC A,B LD B,A $70 LD A,(HL) LD (DE),A INC HL INC DE LD A,(HL) LD (DE),A INC HL INC DE INC C INC C JP NZ,$70 INC B JP NZ,$70 .ENDC ; now build a MSCW as if this were a CLP $80 PUSH HL ; mssp LD HL,(IPCSAV) ; msipc PUSH HL LD HL,(SEGP) ; msseg PUSH HL LD HL,(JTAB) ; msjtab PUSH HL LD HL,(MP) ; msdyn PUSH HL PUSH HL ; msstat ;check for stack overflow CALL STKCHK JP C,STKOVR ; set up environment for called procedure LD HL,0000H ; (MP) := SP ADD HL,SP LD (MP),HL LD DE,DISP0 ADD HL,DE LD (MPD0),HL LD HL,(NEWSEG) LD (SEGP),HL LD HL,(NEWJTB) LD (JTAB),HL ; DE := entric DEC HL LD D,(HL) DEC HL LD E,(HL) LD A,L ; negative self-relative, asusual SUB E LD C,A LD A,H SBC A,D LD B,A LD HL,(RETADR) JP (HL) CLP ; Call local procedure CALL BLDMSCW ; Does everything for CLP JP BACK CGP ; Call global procedure CALL BLDMSCW POP HL ; Junk stat pointer BLDMSCW gave us... LD HL,(BASE) PUSH HL ; ... and make stat point to BASE JP BACK CBP ; Call base procedure CALL BLDMSCW ; and then make this a BASE MSCW CBPXNL LD HL,(BASE) ; save old base pointer PUSH HL PUSH BC ; save new IPC EX DE,HL ; then make this MSCW the new base LD HL,(MPD0) LD (BASED0),HL LD HL,(MP) LD (BASE),HL EX DE,HL ; Use the old base's statlink... LD C,(HL) INC HL LD B,(HL) EX DE,HL ; ...as our own statlink LD (HL),C INC HL LD (HL),B POP BC ; get back IPC JP BACK CIP ; Call intermediate procedure CALL BLDMSCW ; then try to point statlink at parent CIPXNL PUSH BC ; save IPC for awhile LD HL,(MP) ; BC := ^new MSCW LD C,L LD B,H LD HL,(JTAB) ; A := lex level of called proc INC HL LD A,(HL) DEC A JP P,$10 ; if lex level <= 0, base procedure POP BC ; get back ipc JP CBPXNL ; and do call base proc stuff ; find first proc with lex level one less than ours $10 ; see if this is the MSCW that has the goods we need LD HL,MSJTAB+1 ; HL := ^msjtab (high byte) ADD HL,BC LD D,(HL) ; DE := ^jump table DEC HL LD E,(HL) DEC HL ; BC := msdyn, ^ next mscw LD B,(HL) DEC HL LD C,(HL) EX DE,HL ; get lexl from jtab INC HL CP (HL) JP NZ,$10 POP DE ; get IPC POP HL ;junk old stat link PUSH BC ; new msstat is the found mscw LD C,E ; set up IPC again LD B,D JP BACK .INCLUDE Z8080:PROC2.TEXT ; Copyright (c) 1978 ; by Regents of the University of California ; San Diego ; Start of file PROC2 CXP ; Call external (different segment) procedure ; Find or read in desired seg, then CIP it LD A,(BC) ; A := seg_num INC BC LD HL,(SEGP) ; are we already in this seg. (can happen CP (HL) ; when op sys does calls to read, etc.) JP Z,CIP AND A ; is this a call to the op sys (seg 0) ? JP NZ,$10 ; this IS a call to op sys INC A ; indicate CXP via a 1 in A... PUSH AF ; ...and push Carry = false, to inidicate no ; code has been read in LD HL,(INTSEGT) ; bump up refcount, and set INC HL ; (NEWSEG) := MEMTOP LD (INTSEGT),HL LD HL,(MEMTOP) JP $20 $10 ; Call to arbitrary, different segment SAVIPC ; A = segnumber, so CALL GETSEG ; get segment into memory LD A,1 ; indicate this is a CXP call PUSH AF ; carry flag set or reset by GETSEG GETIPC ; get back ipc, bu don't touch DE EX DE,HL ; HL := ^seg just read in $20 LD (NEWSEG),HL CALL BLDXNL ; build a MSCW JP CIPXNL ; then set up stat link READSEG ; read in segment from disk, setting newseg, segbot ; use seg_num as index into segment directory... LD HL,(SEGNUM) ; HL := 6*seg_num LD H,00H ADD HL,HL LD E,L LD D,H ADD HL,HL ADD HL,DE LD DE,SEGTBL+04H ; HL := ^seg_len ADD HL,DE LD (SEGTP),HL LD E,(HL) ; DE := seg_len INC HL LD D,(HL) LD A,E ; if seg_len = 0 then seg non-existent OR D JP Z,NOPROC LD HL,0 ; (NEWSEG) := SP, as that is where proc ADD HL,SP ; table will end up (remember ret addr.) LD (NEWSEG),HL POP BC ; grab ret addr. SUBHLDE ; extend stack by seg_len INC L ; compensate for ret. addr. messing up INC HL ; above calculations LD SP,HL PUSH BC ; restash ret addr. LD (SEGBOT),HL ; push parameters on stack for read routine... LD HL,(SEGTP) ; unit number DEC HL DEC HL DEC HL LD B,(HL) DEC HL LD C,(HL) PUSH BC LD HL,04H ; beginning address ADD HL,SP PUSH HL PUSH DE ; seg_len LD HL,(SEGTP) ; block on disk code is at DEC HL LD B,(HL) DEC HL LD C,(HL) PUSH BC CALL SYSRD LD A,(IORSLT) ;validate the code AND A JP NZ,SYIOER LD HL,(NEWSEG) LD A,(SEGNUM) CP (HL) JP NZ,NOPROC RET ; everything appears to be okay RLLIST ; relocate a bunch of locations pointed to by a list of ; self-relative pointers to memory. ; Passed DE = (^number of nodes) + 2 ; HL = relocation delta (amount to add to each mem loc) ; Returns HL = ^last node LD (RLDELTA),HL EX DE,HL DEC HL ; BC := number of nodes in list LD B,(HL) DEC L LD C,(HL) $10 LD A,C ; done yet ? OR B RET Z ; nope. set DE := ^word that needs relocating DEC HL LD D,(HL) ; nodes are self-relative pointers DEC L LD A,L SUB (HL) LD E,A LD A,H SBC A,D LD D,A PUSH HL ; save node pointer until next time around EX DE,HL ; do the relocation LD A,(RLDELTA) ADD A,(HL) LD (HL),A INC HL LD A,(RLDELTA+1) ADC A,(HL) LD (HL),A POP HL ; get back node pointer... DEC BC ; ...and try another round JP $10 RLSEG ; Relocate an entire segment. ; Given newseg = ^segment, segbot = ^ bottom of segment, ; rlbased0 = ^ base to use in base relocation ; Each proc has its own entric to relocate pc relative stuff. ; While we're at it, turn all assembly self-relative entrics ; into absolute addresses ; A := # of procedures in seg LD HL,(NEWSEG) INC L LD A,(HL) DEC L ; leave HL = 2 + ^proc 1 jtab pointer $10 ; relocate one procedures worth PUSH AF ; save number of procs left ; DE := ^jtab for proc. DEC HL LD D,(HL) DEC L LD A,L SUB (HL) LD E,A LD A,H SBC A,D LD D,A PUSH HL ; save ^proc jtab pointer ; is relocation needed ? proc # = zero means assembly proc. EX DE,HL LD A,(HL) TSTA JP NZ,$20 ; too bad. Change entric to an absolute mem address, and store ; that address in (PROCBOT) DEC HL DEC L LD A,L SUB (HL) LD (HL),A LD E,A INC L LD A,H SBC A,(HL) LD (HL),A LD D,A DEC L EX DE,HL LD (PROCBOT),HL ; relocate base relative stuff LD HL,(RLBASE) CALL RLLIST ; relocate seg relative stuff EX DE,HL LD HL,(SEGBOT) CALL RLLIST ; relocate proc relative stuff EX DE,HL LD HL,(PROCBOT) CALL RLLIST ; that wasn't so bad. get back old proc pointer, and # of procs $20 POP HL POP AF DEC A JP NZ,$10 ; what a relief. All done RET GETSEG ; callable routine to insure a segment is in memory ; takes: A = segnum ; returns: DE = ^seg, carry set if code read in ; look in internal table to get refcount for seg ; if refcount > 0, seg in memory, and so increment refcount. ; otherwise we have to open a space on the stack, read in seg, ; relocate any assembly language stuff according to strange and ; mysterious conditions, make the refcount for the seg 1, and ; fill in the entry telling where the seg is. POP HL ; save return address LD (RETADR2),HL LD (SEGNUM),A LD L,A ; calc address of desired refcount LD H,0 ADD HL,HL ADD HL,HL LD DE,INTSEGT+1 ; HL := 1 + ^intsegt[segnum].refcount ADD HL,DE LD A,(HL) LD D,A ; save high byte, on the offchance refcount > 0 DEC L OR (HL) JP Z,GSGREAD ; whew...segment is in core. LD E,(HL) ; increment refcount INC DE LD (HL),E INC L LD (HL),D INC HL ; now set DE = ^seg LD E,(HL) INC L LD D,(HL) CLRCF ; indicate no code read in JP GSGXIT GSGREAD ; need to bring in seg off disk ; HL points to low byte of refcount LD (REFP),HL ; so stash HL, as info handy later CALL READSEG ; bring in the segment off disk ; Decide how to calc base relocation info... ; if we are loading in a base segment procedure, ; then calc future base, ; else use current base, as will not change when seg is called LD HL,(NEWSEG) DEC HL ; DE := ^proc1's jtab LD D,(HL) DEC L LD A,L SUB (HL) LD E,A LD A,H SBC A,D LD D,A ; if assembly procedure then relocate against old BASE ; (note that seg 1 disallowed from having BASE relocate stuff ; so it doesn't matter how its base stuff is relocated) EX DE,HL LD A,(HL) TSTA JP Z,$05 ; look at proc 1's lex level, if zero then this is a BASE procedure INC HL ; point HL at lex level LD A,(HL) TSTA JP Z,$10 $05 ; use current base as relocation LD HL,(BASE) JP $20 $10 ; calculate what base will be ; (Crystal Ball, so many things I need to know. --Styx) LD DE,-6 ; HL := 1 + ^parmsize ADD HL,DE LD D,(HL) ; DE := parmsize, BC := datasz DEC L LD E,(HL) DEC HL LD B,(HL) DEC L LD C,(HL) EX DE,HL ; set HL := SP-(datasz+parmsize+mscwsize) ADD HL,BC LD BC,MSCWSIZE ADD HL,BC CLRA SUB L LD L,A LD A,0 SBC A,H LD H,A ADD HL,SP $20 LD (RLBASE),HL ; and stash information in a safe place CALL RLSEG ; relocate the sucker. ; fill in intsegt entries correctly LD HL,(NEWSEG) EX DE,HL LD HL,(REFP) INC (HL) ; refcount := 1 INC L INC HL LD (HL),E ; and point at new seg INC L LD (HL),D SCF ; and indicate that code was read in GSGXIT ; leave routine LD HL,(RETADR2) JP (HL) GSEG ; Standard procedure getseg. ; loads in a segment if it isn't in already ; segnum is on tos. POP HL LD A,L CALL GETSEG ; With A = segnum CALL STKCHK ; make sure we didn't wipe out heap JP BACK1 RSEG ; Standard procedure releaseseg ; bumps down refcount, then junks seg if count goes to 0 POP HL LD A,L CALL DECREF ; Decrement refcount for segment # HL JP NZ,BACK1 ; HL = ^entry in intsegt INC HL ; refcount = 0. set DE := ^seg LD E,(HL) INC L LD D,(HL) EX DE,HL ; then set SP := ^seg+2 INC L INC HL LD SP,HL JP BACK1 EXIT ; Exit a specified procedure ; fix IPC of current executing procedure to point to exit code. ; if current proc is the one to exit from, JP BACK1 ; otherwise... ; calculate parent of (BASE), ie., MSCW of PROGRAM pascalsystem. ; BC := (MP) ; repeat ; if BC = system MSCW then die for exitting procedure not called ; change IPC of this MSCW to point to exit code for proc ; done := proc and seg of this MSCW match passed parameters ; BC := MSDYN(BC) ; until done; PROCNUM .EQU WORD1 SYSMSCW .EQU WORD2 POP HL ; param_proc_num LD (PROCNUM),HL POP HL ; param_seg_num LD (SEGNUM),HL ; fix IPC of current proc LD HL,(JTAB) ; HL := ^exitic LD DE,EXITIC ADD HL,DE LD E,(HL) ; DE := exitic (unmodified) INC HL LD D,(HL) SCF ; negative self-relative LD A,L SBC A,E LD L,A LD A,H SBC A,D LD H,A LD (IPCSAV),HL ; done yet ? LD HL,(JTAB) ; check proc num LD A,(PROCNUM) CP (HL) JP NZ,$10 LD HL,(SEGP) ; check seg num LD A,(SEGNUM) CP (HL) JP Z,BACK1 $10 LD HL,(BASE) ; (SYSMSCW) := ^PASCALSYTEM MSCW LD E,(HL) INC HL LD D,(HL) EX DE,HL LD (SYSMSCW),HL LD HL,(MP) ; start at current proc LD C,L LD B,H $20 LD HL,(SYSMSCW) ; about to exit pascalsystem ? LD A,L SUB C JP NZ,$30 LD A,H SBC A,B JP Z,NOEXIT $30 ; nope, it's cool. change this MSCW's IPC LD HL,MSJTAB ; DE := ^proc_num ADD HL,BC LD E,(HL) INC HL LD D,(HL) PUSH DE ; for later use LD HL,EXITIC ; DE := exitic (unmodified) ADD HL,DE LD E,(HL) INC HL LD D,(HL) SCF ; DE := exitic (self-relatived) LD A,L SBC A,E LD E,A LD A,H SBC A,D LD D,A LD HL,MSIPC ; HL := ^MSIPC ADD HL,BC LD (HL),E ; stash new IPC INC HL LD (HL),D DEC HL ; HL := ^MSSEG DEC HL DEC HL EX DE,HL ; done yet ? POP HL ; HL = ^proc_num LD A,(PROCNUM) CP (HL) JP NZ,$40 EX DE,HL ; HL := ^MSSEG LD E,(HL) INC HL LD D,(HL) EX DE,HL LD A,(SEGNUM) CP (HL) JP Z,BACK1 ; (yea!) $40 ; go up dynamic link LD L,C LD H,B INC HL INC HL LD C,(HL) INC HL LD B,(HL) JP $20 ; end of file PROC2 .INCLUDE Z8080:STP.TEXT .IF ~LSTSTP .NOLIST .ELSE .LIST .ENDC ;Copyright (c) 1978 ; by the Regents of the University of California, San Diego ; start of file STP ;******************************************************** ;*****************Standard Procedures*******************; CSP ; Call standard procedure ; extension opcodes and assembly intrinsics. LD A,(BC) ;get proc number INC BC SAVIPC ;for simplicity LD E,A ;index CSPTBL and jump indirect LD D,00H LD HL,CSPTBL ADD HL,DE ADD HL,DE LD E,(HL) INC HL LD D,(HL) EX DE,HL JP (HL) CSPTBL ;Standard Procedure transfer table .WORD IOC ; 0 .WORD NEW .WORD MVL .WORD MVR .WORD EXIT .WORD UREAD ; 5 .WORD UWRITE .WORD IDS .WORD TRS .WORD TIM .WORD FLC ; 10 .WORD SCN .WORD 0 .WORD 0 .WORD 0 .WORD 0 ; 15 .WORD 0 .WORD 0 .WORD 0 .WORD 0 .WORD 0 ; 20 .WORD GSEG .WORD RSEG .WORD TNC .WORD RND .WORD SIN ; 25 .WORD COS .WORD LOG .WORD ATAN .WORD LN .WORD EXP ; 30 .WORD SQT .WORD MRK .WORD RLS .WORD IOR .WORD UBUSY ; 35 .WORD POT .WORD UWAIT .WORD UCLEAR .WORD HLT .WORD MEMA ; 40 MEMA ;function MEMAVAIL: integer (* # words of memory left *) ; LD HL,(NP) ;compute SP-NP XOR A SUB L LD L,A LD A,00H SBC A,H LD H,A ADD HL,SP AND A ;convert to words LD A,H RRA LD H,A LD A,L RRA LD L,A PUSH HL ;return function value JP BACK1 TIM ; Time(var hitime, lotime:integer) - Roger Ramjet strikes again ; Presumably the real-time clock increments the two words ; LOTIME and HITIME every 1/60th of a second POP DE LD HL,(LOTIME) EX DE,HL LD (HL),E INC HL LD (HL),D POP DE LD HL,(HITIME) EX DE,HL LD (HL),E INC HL LD (HL),D RETURN MRK ; mark(VAR i: ^integer) store NP in i CALL CGDIRP ; release GDIRP if necessary POP DE LD HL,(NP) EX DE,HL LD (HL),E INC HL LD (HL),D RETURN RLS ; release(VAR i: ^integer) store contents of i into NP POP HL LD E,(HL) INC HL LD D,(HL) EX DE,HL LD (NP),HL LD HL,NIL ; GDIRP := NIL LD (GDIRP),HL RETURN NEW ; new(VAR p: ^; size_p: integer) ; p := NP; NP := NP+size_p CALL CGDIRP ; release GDIRP if necessary POP BC ; BC := size_p POP DE ; DE := ^p LD HL,(NP) ; p := NP EX DE,HL LD (HL),E INC HL LD (HL),D EX DE,HL ; then extend heap ADD HL,BC ADD HL,BC LD (NP),HL CALL STKCHK ; check for stack overflow JP NC,BACK1 JP STKOVR CGDIRP ;Check Global Directory Pointer ;Roger Ramjet strikes again LD HL,(GDIRP) LD A,L ;THIS CODE RELIES ON NIL===1.!.!.!.!.!.!. DEC A OR H RET Z ;if eql nil then nothing special LD (NP),HL ;else release GDIRP from heap LD HL,NIL LD (GDIRP),HL RET ;**********Editor Intrinsics********* .IF Z80 TSTCNT LD A,B TSTA JP M,$10 OR C ;zero count is also no good JP Z,$10 RET $10 POP HL JP BACK1 .ENDC FLC ; fillchar(buffer: ^; count: integer; ch: char) POP DE POP BC POP HL .IF Z80 CALL TSTCNT ; no work to do if count <= 0 LD (HL),E ;fill one byte DEC BC LD A,B ;are we done? OR C JP Z,BACK1 LD E,L ;if not then propagate char LD D,H INC DE LDIR .ENDC .IF ~Z80 CALL NEGBC ; negate count for easier loop control JP P,BACK1 ; and check for count <= 0 $10 LD (HL),E INC HL INC C JP NZ,$10 INC B JP NZ,$10 .ENDC RESTORE MVBS ; movebytes(source, dest: ^; length:integer); POP BC POP DE POP HL LD A,L ; moveleft or moveright ? SUB E LD A,H SBC A,D JP C,RMOV JP LMOV MVL ;moveleft POP BC POP DE POP HL LMOV ; entry point if from generalized movebytes .IF Z80 CALL TSTCNT LDIR .ENDC .IF ~Z80 CALL NEGBC JP P,BACK1 LD A,C ; move word at a time for extra speed AND 01H JP NZ,$20 $10 LD A,(HL) LD (DE),A INC HL INC DE INC C $20 LD A,(HL) LD (DE),A INC HL INC DE INC C JP NZ,$10 INC B JP NZ,$10 .ENDC RESTORE MVR ;moveright POP BC POP DE POP HL RMOV ; entry from movebytes EX DE,HL ; start at other end of arrays ADD HL,BC EX DE,HL ADD HL,BC .IF Z80 CALL TSTCNT DEC HL DEC DE LDDR .ENDC .IF ~Z80 CALL NEGBC JP P,BACK1 LD A,C ; move word at a time AND 01H JP NZ,$20 $10 DEC HL DEC DE LD A,(HL) LD (DE),A INC C $20 DEC HL DEC DE LD A,(HL) LD (DE),A INC C JP NZ,$10 INC B JP NZ,$10 .ENDC RESTORE SCN ; scan(maxdisp: integer; forpast: (forch, pastch); ch: char; ; start: ^; mask: PACKED ARRAY[0..7] of boolean): integer ; scan until either ; maxdisp characters examined, or ; a match (if forpast=forch) or non-match (if forpast=pastch) occurs. ; as function value return end_position-start POP HL ; junk the mask (fuckin' Richard) POP HL ; HL := start POP DE ; E := ch POP AF ; Carry flag set if scan past POP BC ; BC := maxdisp PUSH HL ; (SP) := start, so as to make function ; value easy to calculate later JP NC,$10 CALL SCPSTX JP SCOUT $10 CALL SCFORX SCOUT ; function return HL_final-HL_initial POP DE ;saved initial SUBHLDE PUSH HL RESTORE SCFOR ; scanfor(maxdisp:integer; ch: char; start: ^; ; mask: PACKED ARRAY[0..7] OF boolean): integer CALL SPARMS SCFORX INC B ;test for scan up or down DEC B JP M,$30 CALL NEGBC RET P ; maxdisp = 0 ? LD A,E ; A := ch $20 CP (HL) RET Z INC HL INC C JP NZ,$20 INC B JP NZ,$20 RET $30 LD A,E ; A := ch $40 CP (HL) RET Z DEC HL INC C JP NZ,$40 INC B JP NZ,$40 RET SCPST ;scanpast(........ CALL SPARMS SCPSTX LD A,B ; which way to scan ? TSTA JP M,$70 CALL NEGBC RET P ; done if maxdisp = 0 LD A,E $60 CP (HL) RET NZ INC HL INC C JP NZ,$60 INC B JP NZ,$60 RET $70 LD A,E $80 CP (HL) RET NZ DEC HL INC C JP NZ,$80 INC B JP NZ,$80 RET SPARMS ; get params for scanfor or scanpast ; (SP) := SCOUT; (SP+2):=HL:=start; E:=ch; BC:=maxdisp POP HL ; return_addr POP DE ; junk mask POP DE ; DE := start POP BC ; A := ch LD A,C POP BC ; BC := maxdisp PUSH DE PUSH HL EX DE,HL LD E,A RET ;**********Compiler Intrinsics****** ; idsearch(VAR symcursor: cursrange; symbufp: ^symbufarray) ; The following declaration order for the compiler is assumed, as IDSCH is ; passed only ^symcursor. ; symcursor: cursrange (* index into symbufarray *); ; sy: symbol (* symbol = (ident..othersy), set by info in reswrdtable *); ; op: operator (* more info from reswrdtable *); ; id: alfa (* packed array [1..8] of char, gets filled with first 8 chars ; of token isolated by IDSRCH if token is an identifier *); ; Isolate token, converting to upper case. ; If token in reswrdtable set sy and op from table, ; else set st := ident, and put first 8 chars (left-justified) of ; token into id. ; symcursor is left pointing to the last char of the token SYMCUR .EQU WORD1 ; index into symbufarray SYMBUFP .EQU WORD2 ; ^symcursarray RESWRDP .EQU WORD3 ; ^reswrdtable IDEND .EQU WORD4 ; loop control TOKEN .EQU BLOCK1 ; first 8 chars of isolated token goes here RESTBL ; reswrdtable ; TYPE table = RECORD ; indexes: ARRAY ['A'..succ('Z')] OF integer; ; tokens: ARRAY [0..#] OF RECORD ; tokenname: alfa; ; tokentype: symbol; ; optype: operator ; END ; END; ; Index part .WORD 0, 2, 3, 5, 8, 11., 15., 16., 16. .WORD 20., 20., 20., 21., 22., 23., 25., 28., 28. .WORD 30., 33., 36., 39., 40., 42., 42., 42., 42. ; Array part .ASCII "AND " .WORD 39., 2 .ASCII "ARRAY " .WORD 44., 15. .ASCII "BEGIN " .WORD 19., 15. .ASCII "CASE " .WORD 21., 15. .ASCII "CONST " .WORD 28., 15. .ASCII "DIV " .WORD 39., 3 .ASCII "DO " .WORD 6., 15. .ASCII "DOWNTO " .WORD 8., 15. .ASCII "ELSE " .WORD 13., 15. .ASCII "END " .WORD 9., 15. .ASCII "EXTERNAL" .WORD 53., 15. .ASCII "FOR " .WORD 24., 15. .ASCII "FILE " .WORD 46., 15. .ASCII "FORWARD " .WORD 34., 15. .ASCII "FUNCTION" .WORD 32., 15. .ASCII "GOTO " .WORD 26., 15. .ASCII "IF " .WORD 20., 15. .ASCII "IMPLEMEN" .WORD 52., 15. .ASCII "IN " .WORD 41.,14. .ASCII "INTERFAC" .WORD 51., 15. .ASCII "LABEL " .WORD 27., 15. .ASCII "MOD " .WORD 39., 4 .ASCII "NOT " .WORD 38., 0 .ASCII "OF " .WORD 11., 15. .ASCII "OR " .WORD 40., 7 .ASCII "PACKED " .WORD 43., 15. .ASCII "PROCEDUR" .WORD 31., 15. .ASCII "PROGRAM " .WORD 33., 15. .ASCII "RECORD " .WORD 45., 15. .ASCII "REPEAT " .WORD 22., 15. .ASCII "SET " .WORD 42., 15. .ASCII "SEGMENT " .WORD 33., 15. .ASCII "SEPARATE" .WORD 54., 15. .ASCII "THEN " .WORD 12., 15. .ASCII "TO " .WORD 7., 15. .ASCII "TYPE " .WORD 29., 15. .ASCII "UNIT " .WORD 50., 15. .ASCII "UNTIL " .WORD 10., 15. .ASCII "USES " .WORD 49., 15. .ASCII "VAR " .WORD 30., 15. .ASCII "WHILE " .WORD 23., 15. .ASCII "WITH " .WORD 25., 15. ; Initialize: put passed and synthesized parameters into fixed locations ; and blank-fill TOKEN. IDS LD HL,RESTBL ;old version entry point JP IDSRCHX IDSRCH POP HL IDSRCHX LD (RESWRDP),HL POP HL LD (SYMBUFP),HL POP HL LD (SYMCUR),HL LD HL,TOKEN LD A,20H ; ' ' LD B,07H ; blank-fill last 7 chars $10 INC HL LD (HL),A DJNZM $10 ; Copy the first 8 chars of the token into TOKEN and set SYMCUR ; to point at the very last character. LD HL,(SYMCUR) ; DE := ^beginning of token LD E,(HL) INC HL LD D,(HL) LD HL,(SYMBUFP) ADD HL,DE EX DE,HL LD HL,TOKEN ; HL := ^dest ; HL^ := translate(DE^); DE := DE+1; B := 7; ; WHILE translate(DE^) IN ['A'..'Z', '0'..'9'] DO ; BEGIN ; IF B>0 THEN ; BEGIN B := B-1; HL := HL+1; HL^ := translate(DE^) END; ; DE := DE+1 ; END LD B,7 LD A,(DE) AND 7FH CP 60H JP C,$20 SUB 20H $20 LD (HL),A INC DE ; the identifier scan loop $30 LD A,(DE) ;get char AND 7FH ;mask bit 7 out CP 5FH ;Underscore _ is ignored JP Z,$70 CP 60H ;translated to upper case JP C,$40 SUB 20H $40 CP 41H ; 'A' JP C,$50 CP 41H+26. ; 'Z' JP C,$60 $50 CP 30H ; '0' JP C,SCDONE CP 39H+1H ; '9' JP NC,SCDONE $60 ; this is an okay character DEC B JP M,$70 INC HL LD (HL),A $70 INC DE ;inc source pointer JP $30 ; we have an identifier... SCDONE LD HL,(SYMBUFP) ;calc new SYMCUR := DE-1-(SYMBUFP) SCF LD A,E SBC A,L LD E,A LD A,D SBC A,H LD D,A LD HL,(SYMCUR) ;stash new index LD (HL),E INC HL LD (HL),D ; Locate TOKEN in reswrdtable if possible LD A,(TOKEN) ;first char as index CALL CALCAD ; HL := ^start looking record PUSH HL LD A,(TOKEN) ; succ(first char) as index INC A CALL CALCAD ; (IDEND) := ^stop looking record LD (IDEND),HL POP DE $100 LD A,L ; done looking yet ? SUB E JP NZ,$110 LD A,H SBC A,D JP Z,NOTOKE $110 PUSH DE ; save for next time around LD B,7 ;comp for 7 chars (first is okay) LD HL,TOKEN+1 $120 INC DE LD A,(DE) CP (HL) JP NZ,$130 INC HL DJNZM $120 JP IDMATCH $130 POP DE ; ^record we just looked at LD HL,0CH ; size of each record ADD HL,DE EX DE,HL LD HL,(IDEND) JP $100 IDMATCH POP HL ; junk ^record we're looking at LD HL,(SYMCUR) ;match, now return type and op INC HL INC HL ; HL = ^sy, DE = ^tokentype (in table) -1 LD B,04H $150 INC DE LD A,(DE) LD (HL),A INC HL DJNZM $150 JP BACK1 NOTOKE LD HL,(SYMCUR) ; We can't find what we wanted...TOKEN isn't INC HL ; a reserved word. (You probably thought it INC HL ; meant we didn't have any papers!) LD (HL),00H ; return sy := ident... INC HL LD (HL),00H INC HL INC HL INC HL LD DE,TOKEN ; ...and copy TOKEN into id. LD B,08H $170 LD A,(DE) LD (HL),A INC DE INC HL DJNZM $170 JP BACK1 CALCAD ; set HL := ^reswordtable.tokens[reswrdtable.indexes[A-'A']] SUB 41H ;'A' normalize index ADD A,A LD C,A LD B,00H LD HL,(RESWRDP) ; BC := reswrdtable.indexes[A-'A'] ADD HL,BC LD C,(HL) INC HL LD B,(HL) LD L,C ;now mult by recsz of 0CH, 1100b, 12. LD H,B ADD HL,BC ADD HL,BC ADD HL,HL ADD HL,HL EX DE,HL ; DE := byte offset for TOKENS LD BC,2*27. ; size of indexes LD HL,(RESWRDP) ADD HL,DE ADD HL,BC ;do final indexing, leave junk in HL RET ; treesearch(rootp: ^node; VAR foundp:^node; VAR target: alfa): integer ; TYPE node = RECORD ; key: alfa; ; rlink: ^node; ; llink: ^node ; END; ; function returns... ; 0: foundp points to matching node ; +1: foundp points to a leaf, and target>foundp.key ; -1: foundp points to a leaf, and target 0 LD HL,(IORSLT) LD A,L OR H JP Z,BACK JP UIOERR IOR ; IO result - return IORSLT LD HL,(IORSLT) PUSH HL RETURN GETU ;get logical unit number and validate XOR A ;assume operation is going to be valid LD (IORSLT),A POP HL ; get LUN from under the retn adrs EX (SP),HL LD A,L ;0 < LUN <= MAXU ... AND A JP Z,BLUN CP MAXU+1 JP NC,BLUN LD (UNIT),A ;save for driver ADD A,A ;times UNITBL elt size ADD A,A LD H,00H LD L,A LD DE,UNITBL ;index into UNITBL ADD HL,DE LD (UPTR),HL ; save this also LD A,(UREQ) ; validate request AND (HL) RET NZ ; and return BDIR LD A,03H ; bad I/O direction JP BOMIT BLUN LD A,02H ; bad unit number BOMIT LD (IORSLT),A POP HL JP BACK1 UBUSY LD HL,00H ; assume false ... EX (SP),HL ; and insert under LUN PUSH HL UWAIT LD A,INBIT|OUTBIT LD (UREQ),A CALL GETU JP BACK1 ;Boy that was easy. UCLEAR LD A,CLRBIT LD (UREQ),A LD HL,BACK1 LD (URTN),HL CALL GETU JP CALLIO SYSRD LD HL,00H EX (SP),HL LD A,INBIT JP SYSIO UWRITE LD A,OUTBIT JP UIO UREAD LD A,INBIT UIO LD HL,BACK1 SYSIO LD (UREQ),A LD (URTN),HL POP HL ; junk async param LD (UASY),HL POP HL ; put others in param space LD (UBLK),HL POP HL LD (ULEN),HL POP HL LD (UBUF),HL CALL GETU ; get unit number, form table adrs CALLIO INC HL ; get driver adrs from table INC HL LD E,(HL) INC HL LD D,(HL) LD HL,(ULEN) ; check for no bytes LD A,H OR L JP Z,IOXIT EX DE,HL JP (HL) ; GO FOR IT || IOXIT LD HL,(URTN) JP (HL) ; Be see'n you. ;********* DISK DRIVER FOR CPM *************************** BYPS .EQU 80H ;Bytes per sector DSCT0 .BYTE 00H DSCT .BYTE 00H DTRK .BYTE 00H DR0DRVR LD C,00H ;select drive JP DSK0 DR1DRVR LD C,01H DSK0 LD L,1BH ;BIOS/SELDSK CALL BIOS LD A,(UREQ) AND CLRBIT JP Z,$10 LD L,18H ;BIOS/HOME CALL BIOS JP XDSK $10 ;Start initializing for the loop LD HL,(ULEN) ;HI(ULEN) = # sectors to do ADD HL,HL INC H ;adjust for predecr in loop LD (ULEN),HL LD HL,(UBUF) LD C,L LD B,H LD L,24H ;BIOS/SETDMA CALL BIOS LD HL,(UBLK) ;LSN := 4*BLOCK ADD HL,HL ADD HL,HL LD BC,1AH ; Q,R := LSN div,mod 26 CALL DIVPOS ; HL=R, DE=Q PUSH HL PUSH DE LD A,E INC A LD (DTRK),A LD C,A LD L,1EH ;BIOS/SETTRK CALL BIOS POP DE LD A,06H ; S0 := 6*Q LD HL,0000H $20 ADD HL,DE DEC A JP NZ,$20 LD BC,1AH ; S0 := S0 mod 26 +1+(R>12) CALL DIVPOS INC HL POP DE ;get R LD A,E CP 0CH+1 JP C,$30 INC HL $30 LD A,L LD (DSCT0),A ADD A,E ; S := S0+2*R-1 mod 26 +1 ADD A,E DEC A $40 SUB 1AH JP NC,$40 ADD A,1AH+1 LD (DSCT),A LD C,A LD L,21H ;BIOS/SETSEC CALL BIOS $50 ;--------LOOP ON SECTORS, Gross Control, Kludge. LD HL,(ULEN) DEC H LD (ULEN),HL JP NZ,$80 LD A,L RRCA JP C,$60 AND A JP Z,XDSK INC H INC L LD (ULEN),HL LD A,(UREQ) ;do whole sector anyway on output AND OUTBIT JP NZ,$80 LD HL,-BYPS ;fractional read, oh shoot. ADD HL,SP LD SP,HL LD C,L LD B,H LD L,24H ;BIOS/SETDMA CALL BIOS JP $80 $60 LD A,(UREQ) ;what happened to the fraction? AND OUTBIT JP NZ,XDSK ;lots to do if read though LD HL,(UBUF) LD DE,-BYPS ADD HL,DE EX DE,HL LD HL,0000H ADD HL,SP LD A,(ULEN) RRA LD B,A $70 LD A,(HL) LD (DE),A INC HL INC DE DEC B JP NZ,$70 LD HL,BYPS ADD HL,SP LD SP,HL JP XDSK $80 LD A,(UREQ) ;now finally do the I/O request AND OUTBIT JP Z,$90 LD L,2AH ;BIOS/WRITE JP $100 $90 LD L,27H ;BIOS/READ $100 CALL BIOS AND A ;test for I/O errors from CPM JP Z,$110 LD A,04H LD (IORSLT),A $110 LD HL,(UBUF) LD DE,BYPS ADD HL,DE LD (UBUF),HL LD C,L LD B,H LD L,24H ;BIOS/SETDMA CALL BIOS LD A,(DSCT) ; S := S+1 mod 26 +1 ADD A,02H CP 1BH JP C,$120 SUB 1AH $120 LD HL,DSCT0 ; if S = S0 then CP (HL) JP NZ,$150 INC A ; S := S+1 RRCA ; if odd(s) then RLA JP NC,$140 ADD A,04H ; S := S+4 mod 26 CP 1AH+1 JP C,$130 SUB 1AH $130 PUSH AF ; T := T+1 LD A,(DTRK) INC A LD (DTRK),A LD C,A LD L,1EH ;BIOS/SETTRK CALL BIOS POP AF $140 LD (DSCT0),A ; S0 := S $150 LD (DSCT),A LD C,A LD L,21H ;BIOS/SETSEC CALL BIOS JP $50 ;--------KEEP ON TRUCKIN'. XDSK JP IOXIT ;*** ALL PURPOSE BIOS LINKER *** BIOS LD A,(0002H) ; do YOU believe this will work LD H,A JP (HL) ;************* DRIVER FOR ALL CHARACTER ORIENTED DEVICES ON CPM ************** CLAST .BYTE 0 CIVECT .BYTE 0 COVECT .BYTE 0 CTABLE .BYTE 00H,00H .BYTE 09H,0CH,09H,0CH ;BIOS/CONIN,CONOUT .BYTE 00H,00H,00H,00H,00H,Ê0H .BYTE 00H,0FH,15H,12H ;BIOS/LIST,READER,PUNCH CHDRVR LD A,(UREQ) AND CLRBIT JP Z,CH01 ; clear out console input stream XOR A LD (CLAST),A CALL CHCLR JP CHX CHDRVR1 LD A,(UREQ) AND CLRBIT JP NZ,CHX CH01 CALL SETVECT ; set up BIOS in and out vectors LD HL,(ULEN) ;prepare for loop EX DE,HL LD HL,(UBUF) $10 LD A,E ;---LOOP--- length zero yet ? OR D JP Z,CHX DEC DE LD A,(UREQ) ;which direction AND OUTBIT JP Z,$20 LD C,(HL) ;do output CALL ECHO JP $30 $20 CALL CBIS ;do input LD C,A LD (HL),A LD A,(UNIT) CP 01H JP NZ,$30 CALL ECHO LD A,(UASY) AND DRCTBIT JP NZ,$30 LD A,(SYEOF) ; if eof char, zero out rest of request buffer CP (HL) JP NZ,$30 INC DE $25 LD (HL),0 DEC DE INC HL LD A,E OR D JP NZ,$25 JP CHX $30 INC HL JP $10 CHX JP IOXIT ECHO ;char in the Creg is interpreted and output LD A,(UASY) AND DRCTBIT JP Z,$10 CALL CBOS JP $40 $10 LD A,(CLAST) CP 10H ;DLE- blank expansion JP NZ,$30 LD A,C SUB 20H LD (CLAST),A $20 LD A,(CLAST) DEC A JP M,$40 LD (CLAST),A LD C,20H CALL CBOS JP $20 $30 LD A,C ;output done here LD (CLAST),A CP 10H JP Z,$40 CALL CBOS LD A,(CLAST) CP 0DH ;CR- requires an LF JP NZ,$40 LD A,0AH LD (CLAST),A LD C,A CALL CBOS $40 RET CHCLR LD L,06H ;BIOS/CONST CALL BIOS AND A RET Z LD L,09H ;BIOS/CONIN CALL BIOS JP CHCLR SETVECT LD HL,(UNIT) ;compute BIOS vector LD H,00H ADD HL,HL LD DE,CTABLE ADD HL,DE LD A,(HL) LD (CIVECT),A INC HL LD A,(HL) LD (COVECT),A RET ;routines called by the character driver. CBIS LD A,(CIVECT) JP CBIS1 CBOS LD A,(COVECT) CBIS1 PUSH HL PUSH DE LD L,A CALL BIOS POP DE POP HL RET ; end of file CPMIO .INCLUDE Z8080:BOOT.TEXT .IF ~LSTBOOT .NOLIST .ELSE .LIST .ENDC ;Copyright (c) 1978 ; by the Regents of the University of California, San Diego ; Beginning of file BOOT ;****************BOOTSTRAP LOADER****************; ; This is a Pascal-system loader, it assumes that ;the complete interpreter and booter have been ;loaded by the host machine. It assumes that on ;unit 4 ,block 2 is a directory with the pascal ;operating system 'SYSTEM.PASCAL'. The booter ;reads this, initializes the interpreter to enter ;the system outer block and goes to it. ; Six easy steps toward the realization of Pascal. ; 1: initialize all I/O drivers ; 2: read directory, find 'SYSTEM.PASCAL' ; 3: read block zero and set up SEGTBL ; 4: read in segment zero ; 5: set up machine state for seg 0 proc 1 ; 6: GO FOR IT. .ALIGN 2 ;These decs are for Step 2. INTEND ;Marks the end of the core resident interpreter SYSTLE .BYTE 0DH ;length byte of String .ASCII "SYSTEM.PASCAL" ;characters of String DENTSZ .EQU 1AH ;directory entry size, bytes DTITLE .EQU 06H ;offset of title in an entry DENTP .WORD 0 ;gets set by this Step SYSBLK .WORD 0 SEGCNT .BYTE 0 QWIK ; Assume p-code at 2000H, move to high core LD HL,(2006H) ; Get code length (bytes) EX DE,HL LD HL,(MEMTOP) ; Get maximum memory address SUBHLDE ; Get address to transfer program to LD SP,HL ; Stack grows from here LD DE,2200H ; Address of start of p-code LD BC,(2006H) ; Set byte counter to # of bytes to transfer CLRA ; Get SUB C ; negative LD C,A ; byte LD A,00H ; count SBC A,B ; LD B,A $10 LD A,(DE) ; Get byte to transfer LD (HL),A ; Move byte to new home INC DE ; Bump address INC HL ; Bump destination address INC C ; Increment lower part of byte count JP NZ,$10 ; Overflow into upper byte ? INC B ; Yes, increment upper one, too JP NZ,$10 ; Are we done (BC=0) ? DEC HL ; Yes, adjust HL for DEC HL ; STEP5 of booter JP STEP5 ; COWABUNGA !!!!! BOOT ;Start here and follow the yellow brick road. LD SP,RELSEG+1000H ;if that doesn't do it I'll be .IF CPM LD HL,(0001H) ;BIOS JUMP VECTOR LD DE,-11H ; leave some space for shitty (Tarbell) BIOS ADD HL,DE LD (MEMTOP),HL .ENDC ; Step 1 ;Initialize all I/O drivers. .IF CML LD A,0C3H ; set up keyboard interrupt vecto LD (38H),A LD HL,CHINT LD (39H),HL .ENDC ; Step 2 ;read directory from abs block 2 into ;memory just above the interp ;find system.pascal and leave the ;address of its direntry in DENTP ; read in the directory LD HL,(SYSUNT) ;unit number for booting PUSH HL LD HL,NRPTOP ;I/O buffer, way out there PUSH HL LD HL,04H*200H ;length, 4 blocks PUSH HL LD HL,02H ;DIR starts at block 2 PUSH HL CALL SYSRD ; that does it folks ; search dir LD HL,FSTENT ;skip over entry 0, disk name LD (DENTP),HL LD C,00H ; ;(DENTP)=^DIR ENTRY, HL=^DIR.TITLE, DE=^SYSTITLE, C=counter $20 ;outer, loop on each dir entry LD DE,DTITLE ;inc HL to .TITLE in entry ADD HL,DE LD DE,SYSTLE ;set DE to title for comparison LD B,0EH ;comp for length of title $30 ;inner, loop on characters LD A,(DE) CP (HL) JP NZ,$40 INC DE INC HL DJNZM $30 JP FOUND $40 ; No match here - go to next dir entry LD HL,(DENTP) LD DE,DENTSZ ADD HL,DE LD (DENTP),HL DEC C JP NZ,$20 $45 JP $45 ; We didn't find it. Maybe one of this days ; we'll put out an error message here. FOUND ;adrs left in DENTP ; Step 3 ;RELSEG .EQU NRPTOP+800H ;address to read block 0 at, above dir ;SYSBLK .WORD 0 ;amount to make rel seg blk nos absolute ;SEGCNT .BYTE 0 ;do the read LD HL,(SYSUNT) ;unit PUSH HL LD HL,RELSEG ;buffer PUSH HL LD HL,40H ;length, 16 entries PUSH HL LD HL,(DENTP) ;block, from directory LD C,(HL) INC HL LD B,(HL) PUSH BC LD L,C LD H,B LD (SYSBLK),HL CALL SYSRD ;put stuff into SEGTBL ; HL => RELSEG: array [0..15] of ; DISKADR, relative block number ; CODELEN length in bytes ; DE => SEGTBL: array [0..15] of ; UNIT, device index ; BLOCK, absolute ; LENGTH same as above LD A,10H ;loop control LD (SEGCNT),A LD DE,SEGTBL LD HL,RELSEG $50 LD A,(SYSUNT) ;set SEGTBL.UNIT := 4 LD (DE),A INC DE XOR A LD (DE),A INC DE LD C,(HL) ;BC := RELSEG.DISKADR INC HL LD B,(HL) INC HL PUSH HL ;calc abs block num LD HL,(SYSBLK) ADD HL,BC EX DE,HL LD (HL),E INC HL LD (HL),D INC HL EX DE,HL ;restore pointers POP HL LD A,(HL) ;set SEGTBL.LENGTH := RELSEG.CODELEN LD (DE),A INC DE INC HL LD A,(HL) LD (DE),A INC DE INC HL LD A,(SEGCNT) ;do this 16 times DEC A LD (SEGCNT),A JP NZ,$50 ; Step 4 ; read segment zero, pointed at by SEGTBL[0], ;into the highest memory address possible, up ;to MAXADR. Also set SP at bottom of code read in. LD HL,SEGTBL+04H ;get len of seg zero LD E,(HL) INC HL LD D,(HL) LD HL,(MEMTOP) INC HL INC HL SUBHLDE LD SP,HL LD A,(SYSUNT) ;unit LD C,A LD B,00H PUSH BC PUSH HL ;buffer PUSH DE ;length LD HL,(SEGTBL+02H) ; block PUSH HL CALL SYSRD ; Fill in internal seg table LD HL,INTSEGT+4 LD BC,- CLRA $60 LD (HL),A INC HL INC C JP NZ,$60 INC B JP NZ,$60 LD HL,1 ; initialize entries for op sys LD (INTSEGT),HL LD HL,(MEMTOP) LD (INTSEGT+2),HL ; Step 5 ; Initialize all P-machine registers including ;SP, NP, MP, BASE, IPC, JTAB, SEG. ;Create an initial stack frame and MSCW including ;the automagic ^SYSCOM parameter. LD HL,(MEMTOP) STEP5 LD (SEGP),HL DEC HL ;set JTAB := SEG^[-1] LD B,(HL) DEC HL LD C,(HL) SUBHLBC ; self relative LD (JTAB),HL DEC HL ;set IPCSAV := JTAB^[-1] LD B,(HL) DEC HL LD C,(HL) SUBHLBC ; self relative LD (IPCSAV),HL LD HL,(JTAB) ;new stack frame LD BC,DATASZ ADD HL,BC ; SP := SP-JTAB^[-8] LD C,(HL) INC HL LD B,(HL) XOR A SUB C LD L,A LD A,00H SBC A,B LD H,A ADD HL,SP LD SP,HL LD DE,SYSCOM ;^SYSCOM parameter PUSH DE PUSH HL ;create MSCW, dummy save state LD HL,-04H ;address of an ABORT opcode ADD HL,SP PUSH HL LD HL,00D6H ; an ABORT opcode PUSH HL PUSH HL LD HL,-04H ;STAT and DYN must be self referencing ADD HL,SP PUSH HL PUSH HL LD (MP),HL ;set all MSCW pointers LD (BASE),HL LD BC,DISP0 ADD HL,BC LD (MPD0),HL LD (BASED0),HL LD HL,INTEND ;set NP LD (NP),HL ; Step 6 ; enable interrupts and do other junky stuff RESTORE NRPTOP .EQU $ RELSEG .EQU NRPTOP+800H FSTENT .EQU NRPTOP+DENTSZ .END GOLOC ;you learn to pray. ; End of file BOOT, and end of interpreter ! .END