Oakland CPM Archive

home *** CD-ROM | disk | FTP | other *** search

/ Oakland CPM Archive / oakcpm.iso / sigm / vol092 / litl-ada.asm < prev next >

Wrap

Assembly Source File | 1984-04-29 | 24.5 KB | 1,000 lines

;Little-Ada L/0 machine interperter ;Edited June 21, 1980 ;Copyright 1980 by Ralph E. Kenyon Jr. ;Version 1547 Re-designated L/1 Jan 81 ;Stripped down, no debug version REFS SYSTEM.SY ;Library file REF Warm ;Warmstart REF WH0 ;Consol Char in REF WH1 ;Consol Char out REF Msg ;Message writer REF USER ;Start of user memory REF MEMTOP ;Last good memory REF Ret ;Return from overlay REF Dio ;Disk In/Out REF Err ;System error handler REF FILE ;File data buffer REF Ovrto ;Overlay handler REF CMPTR ;Command buffer pointer REF Ioret ;Return from Interupt REFS <#>L0CODE.SY ;Open L/0 code MACRO Library REF L0CODE ;Macro which defines all L/0 code macros. CR EQU 13 ORG USER IDNT $,$ ;$ is current value PC JMP Start JMP GO L0CODE LIST 0 DBZ DB CR,'Division by zero not defined!',CR,0 Inst DS 1 ;Instruction register Base DS 2 ;Base register Static DS 2 ;Static link conversion register Level DS 1 ;Level register AR1 DS 2 ;Arithemetic storage 1 AR2 DS 2 ;Arithemetic storage 2 AR3 DS 2 ;Arithemetic storage 3 TMStack DS 2 ;Stack start FDB DS 44 ;File descriptor buffer IFD DS 1 ;Input file drive IFA DS 2 ;Input file disk address IFS DS 2 ;Input file disk sector IFP DS 2 ;Input file buffer pointer IFB DS 256 ;Input file buffer OFD DS 1 ;Output file drive OFA DS 2 ;Output file disk address OFS DS 2 ;Output file disk sector OFP DS 2 ;Output file buffer pointer OFB DS 256 ;Output file buffer Flag DS 1 ;Output file in use flag IFflg DB 1 ;initialize flag OFflg DB 1 ;initialize flag Fetch LDAX B ;Instruction fetch cycle INX B STA Inst ORA A RET Push MOV M,E ;DE to S(t) DCX H ;t+1 to HL MOV M,D DCX H RET Pop INX H ;S(t) to DE MOV D,M ;t-1 to HL INX H MOV E,M RET MinDE PUSH PSW ;Two's complement MOV A,D ;of DE. All other CMA ;registers preserved. MOV D,A MOV A,E CMA MOV E,A INX D POP PSW RET CONV PUSH H ;Requires T in DE CALL MinDE ;(Static) LHLD TMStack DAD D ;<[(TMStack)-(Static)] MOV A,H ;We're going to divide by 2 CMP H ;(Just reset carry) RAR ;Puts lo bit in carry MOV D,A ;Right shifted by 1 MOV A,L ;Lo byte RAR ;Carry goes into hi bit MOV E,A ;(16 bits right shift) POP H RET ;Result in DE ;This section computes the static link ;by finding the ltack position base for ;L levels down. GStL PUSH PSW PUSH H LDA Inst ;get & stow level GStL1 ANI 0FH LHLD Base ;get & stow base SHLD Static JMP BASE BASE1 LHLD Static ;get base XCHG LHLD TMStack INX D ;We need to be above by 1 CALL MinDE DAD D ;(MEMTOP-2*T) DAD D ;stack address now in hl CALL Pop ;Get S(S(t)) XCHG SHLD Static LDA Level ;get level DCR A BASE STA Level JNZ BASE1 XCHG ;Returns static level in DE POP H POP PSW RET Out2 MVI E,2 ;Output file already exists JMP Out0 Out3 MVI E,3 ;Input file not specified Out0 MVI D,7 Out JMP Err Gf MVI A,0E0H Gf1 CALL Ovrto DB 'Gfid' RET ;Parameters for Dio set up by start code ;Here's where we get the file to be ;interpretered GETP CALL Dio ;Go get it. JC Out ;Something Wrong! LXI H,Pgmaddr ;get the program PUSH H POP B ;Set TMPC to first byte LHLD TMStack ;Set initialize TMSP LXI D,0 ;First position on stack for CALL Push ;Character in/out CALL Push ;Static link INX D XCHG SHLD Base ;set Base 1st XCHG CALL Push ;Dynamic link same LXI D,Origin ;addr of that 'hlt' byte CALL Push CALL INB CALL OUTB ;This routine sets itself up as a return address GO PUSH H ;Return to here LXI H,GO XTHL ;Put our addr on stack CALL Fetch RAL JNC branch ;0 means br or bnz RAL JNC oprlic RAL RC ;111XXXXX is NOP CALL GStL ;For both lad & call RAL ;Now which one JC Call ;do we have? ;Here we have to get the address from ;the program immediate data (two bytes) Lad PUSH H LHLD Static CALL Fetch MOV D,A ;Address hi byte CALL Fetch MOV E,A ;Address lo byte DAD D ;Add in the stack base XCHG ;put it in DE POP H JMP Push ;Let push return ;This routine puts links on stack ;followed by return address Call PUSH H ;We need TMSP later XCHG LHLD Static XCHG CALL Push ;Static link first XCHG LHLD Base XCHG CALL Push ;Dynamic link second XTHL ;TMSP to stack XCHG CALL CONV XCHG SHLD Base ;Set new base CALL Fetch ;lets get that address MOV D,A CALL Fetch MOV E,A LXI H,Pgmaddr DAD D XTHL ;Addr to top of stack PUSH B POP D POP B JMP Push ;return address oprlic RAL ;Check next bit for oprlic JC Lic ;For opr, we must get last 5 bits from inst ;We'll use a computed goto to get the ;routine for the sub-operation. opr LDA Inst ANI 1FH ADD A ;Times 2 MOV E,A MVI D,0 PUSH H ;save TMSP LXI H,Jtbl ;jmp table DAD D ;add position MOV E,M INX H MOV D,M XCHG ;addr to HL XTHL ;addr to stack RET ;Jump to addr ;Now we've got to sort out the number of ;bytes used for the constant in this lic Lic RAL JC Lic1 LDA Inst ;1 byte ANI 0FH MVI D,0 JMP lic4 Lic1 RAL JC lic2 LDA Inst ;2 byte ANI 7 JMP lic3 lic2 CALL Fetch ;3 byte lic3 MOV D,A CALL Fetch lic4 MOV E,A JMP Push ;let push RET for us branch RAL JNC Br CALL Pop MOV A,D ORA A JNZ Br ;(bnz) ADD E JNZ Br ;(bnz) JMP Fetch ;Skip this byte ;let Fetch return Br LDA Inst ANI 3FH ;Kill opcode MOV D,A ;Hi addr CALL Fetch ;rest of addr MOV E,A ;Lo addr PUSH H LXI H,Pgmaddr ;Adjust for program DAD D ;load address XTHL POP B RET Jtbl DW Halt ;0 ; Halt closes both the input and the ; output files before invoking Exec. ; The input and output file setup routines ; are restored to IFR and OFR also. DW addsub ;1 DW addsub ;2 DW muldiv ;3 DW muldiv ;4 DW Mod ;5 DW Neg ;6 DW Not ;7 DW Sete ;8 DW Setlg ;9 DW Setlg ;A DW Swap ;B DW retn ;C DW Rav ;D DW Sto ;E DW inc ;F IFR DW INB ;10 ; INB sets up the input file data for Dio ; and puts the address of Inb into IFR. ; If a file is not selected, INB puts the ; address of Cinb into IFR (input from consol) OFR DW OUTB ;11 ; OUTB sets up the output file data for Dio ; and puts the address of Outb into OFR. ; If a file is not selected, OUTB puts the ; address of Coutb into OFR (output to consol) ;These remaining are all treated as nop DW Ret ;12 insurance DW Ret ;13 DW Ret ;14 DW Ret ;15 DW Ret ;16 DW Ret ;17 DW Ret ;18 DW Ret ;19 DW Ret ;1A DW Ret ;1B DW Ret ;1C DW Ret ;1D DW Ret ;1E DW Ret ;1F Halt CALL TURNOFF ;Close open output file LXI H,INB ;Restore Input file SHLD IFR ;Open sequence POP D ;Clean up stack RET addsub CALL Pop ;S(t) PUSH D CALL Pop ;S(t-1) XTHL ;S(t) to HL XCHG ;S(t) to DE LDA Inst ANI 2 ;is it a subtract? CNZ MinDE DAD D ;S(t-1)-S(t) IN HL XCHG POP H ;Get TMSP back JMP Push ;let push return for us muldiv CALL Pop XCHG SHLD AR1 XCHG CALL Pop XCHG SHLD AR2 LDA Inst ANI 4 ;not multiply? CZ MULT CNZ DIVD LHLD AR3 XCHG JMP Push ;let push return for us MULT PUSH PSW ;16 bit multiply PUSH B ;with no overflow test PUSH D ;returns product mod 10000H PUSH H LHLD AR1 MOV A,H ORA A JNZ MULT1 ADD L JZ MULT7 XCHG MULT1 LHLD AR2 MOV A,H ORA A JNZ MULT2 ADD L JZ MULT7 MULT2 MOV C,H ;save hi byte MOV A,L ;do lo byte LXI H,0 MVI B,8 MULT3 RRC JNC MULT4 DAD D MULT4 XCHG DAD H XCHG DCR B JNZ MULT3 MOV A,C ;now do hi byte MVI B,8 MULT5 RRC JNC MULT6 DAD D MULT6 XCHG DAD H XCHG DCR B JNZ MULT5 JMP MULT8 MULT7 LXI H,0 MULT8 SHLD AR3 JMP Ioret DIVD PUSH PSW PUSH B PUSH D PUSH H LXI B,0 ;Result goes here LHLD AR1 MOV A,H ;lets see if ORA A ;the idiot wants JNZ DIVD1 ;to divide by ADD L ;zero. JZ DBZER ;He does! DIVD1 XCHG ;nope, so get LHLD AR2 ;dividend MOV A,D ;If it's ORA A ;zero JNZ DIVD2 ;then ADD E ;result's JNZ DIVD2 ;also DIVD7 LXI H,0 ;zero JMP DIVD6 DIVD2 MOV A,H CMP D JC DIVD4 JZ DIVD3 INX B JMP SUBT DIVD3 MOV A,L CMP E JC DIVD4 INX B JZ DIVD4 SUBT PUSH D CALL MinDE DAD D POP D JMP DIVD2 DIVD4 PUSH B POP H DIVD6 SHLD AR3 JMP Ioret DBZER CALL DBZ1 JMP DIVD7 DBZ1 LXI H,DBZ CALL Msg RET Mod CALL Pop ;S(t) to DE PUSH D ;S(t) to top of stack CALL Pop ;S(t-1) to DE XTHL ;S(t) to HL MOV A,H ;lets see if ORA A ;the idiot wants JNZ Mod1 ;to divide by ADD L ;zero. JNZ Mod1 CALL DBZ1 JMP Mod3 ;He does! Mod1 MOV A,D ;see if we ORA A ;start with JNZ TEST ;zero ADD E JNZ TEST JMP Mod3 SUBTR XCHG PUSH D ;Save CALL MinDE DAD D ;Add -DE POP D ;Restore XCHG TEST MOV A,D ;Hi byte of S(t) CMP H JC Done ;Hi byte of S(t-1) ;<Hi byte of S(t) JNZ SUBTR ;its bigger MOV A,E ;It's equal so CMP L ;Check lo byte JC Done JNZ SUBTR ;its bigger Mod3 LXI D,0 ;its equal Done XCHG XTHL POP D JMP Push ;let push return for us Neg CALL Pop ;S(t) to DE CALL MinDE JMP Push ;DE to S(t) let push ret Not CALL Pop ;look MOV A,D ;hi byte ORA A ;set flags JNZ Not2 Not1 ADD E ;lo byte JNZ Not2 LXI D,1 ;its Zero so change result JMP Push Not2 LXI D,0 JMP Push ;onto stack let ;push ret for us Swap CALL Pop ;S(t) PUSH D ;to TOS CALL Pop ;S(t-1) to DE XTHL ;S(t) TO HL, t-1 to TOS XCHG ;S(t) to DE, S(t-1) to HL XTHL ;t-1 to HL, S(t-1) to TOS CALL Push ;S(t-1) to TOS POP D ;S(t-1) to DE JMP Push ;S(t-1) to TMS ;let push return for us. retn LHLD Base LXI D,3 DAD D DAD H XCHG CALL MinDE LHLD TMStack DAD D CALL Pop ;TMPC PUSH D POP B CALL Pop ;Dynamic link XCHG SHLD Base XCHG INX H ;We don't need that INX H ;static link now RET Sete CALL Pop PUSH D CALL Pop XTHL MOV A,D CMP H JNZ SETE1 MOV A,E CMP L JNZ SETE1 LXI D,1 ;they're equal POP H JMP Push ;let push return for us SETE1 LXI D,0 POP H JMP Push ;let push return for us Setlg CALL Pop PUSH D ;S(t) to TOS CALL Pop ;S(t-1) to DE XTHL ;S(t) to HL LDA Inst ANI 2 ;Setgt? JZ Set1 XCHG ;Reverse for Setgt Set1 CALL MinDE ;-S(t-1) DAD D ;Want 0<S(t)-S(t-1) DCX H ;Sign test uses >= 0 MOV A,H ;Look at sign ORA A ;Set flags POP H ;TMSP LXI D,1 ;Assume true JP Set2 ;Jump if true DCX D ;Falls thru if false Set2 JMP Push ;Let Push return for us ;Note: RAV assumes that the address on the stack ;is a relative address from the TM stack pointer ;with 1 for each 16 bit push or pop. We multiply ;the two's complement by 2 and add it to ;the address in TMStack (Top of memory) Rav CALL Pop ;Get S(t) PUSH H ;Save SP LHLD TMStack INX D ;We need to be above by 1 CALL MinDE DAD D ;(MEMTOP-2*T) DAD D ;stack address now in hl CALL Pop ;Get S(S(t)) POP H ;Restore TMSP JMP Push ;S(t):=S(S(t)) Sto CALL Pop ;S(t) to be stowed PUSH D ;save it CALL Pop ;address to stow S(t) in XTHL ;(We'll want S(t) first) PUSH H ;Need to use HL CALL MinDE ;Convert Stack LHLD TMStack ;address DAD D ;(MEMTOP-2*T) DAD D ;stack address now in hl POP D ;Get S(t) CALL Push ;S(S(T-1)):=S(T) POP H ;T-2 to TMSP RET Inc CALL Pop ;S(t) to de, t-1 in HL CALL MinDE DAD D DAD D ;S(t)+t-1 to HL RET INB PUSH H ;Save VMSP PUSH B ;Save VMPC LXI H,Ifpr ;get one from him. IFR1 LXI D,FILE ;File descriptor buffer LXI B,'AD' ;Default file extension CALL Gf JNC IFR2 ;Gfid found the file ;so go read it XRA A ;Checks for error ADD D ;code 0503H CPI 5 JNZ Err ;Wrong one ADD E CPI 8 ;adds up to 8 JNZ Err ;No good! LXI H,Cinb ;Set up to get input SHLD IFR ;from the consol POP B ;VMPC POP H ;VMSP RET ; Additional inputs jump to here Cinb CALL WH0 ;We're inputting from PUSH H ;the consol LHLD TMStack ;Where it goes MOV M,A ;Put it in POP H ;VMSP RET Ifprn DB CR,'The input file''s empty.' DB CR,'What''s the continuation file''s name? ',0 Ifpr DB 'What''s the input file name? ',0 IFR2 LXI H,FILE ;READ starts here MOV A,M ANI 7 ;trim down to drive no. STA IFD ;Drive number INX H MOV A,M ;FDE flag byte ANI 1FH ;trim to file size ADI 3 ;point past extension MOV E,A ;Put into DE MVI D,0 DAD D ;Add to Address in HL XCHG ;FDA pointer now in DE LXI H,IFA ;Where the addresses go MVI C,4 ;4 bytes to copy CIFD LDAX D ;Get the data MOV M,A ;from the FDB (FILE) INX H ;and copy into the INX D ;areas for our Dio DCR C ;routines JNZ CIFD ;More to copy LXI H,IFB+100H ;Reset the SHLD IFP ;buffer pointer too LXI H,Inb ;Furthur calls to Reader SHLD IFR ;the reader POP B ;VMPC POP H ;VMSP RET ; Routine to input from an open file Inb PUSH H ;Save VMSP PUSH B ;Save VMPC RD1 LHLD IFP LXI D,IFB+100H MOV A,H CMP D JNZ RD2 MOV A,L CMP E JZ RD3 RD2 MOV A,M INX H SHLD IFP POP B ;VMPC LHLD TMStack ;Here's where MOV M,A ;we put it POP H ;VMSP RET RD3 LHLD IFS MOV A,H ORA A JNZ RD4 ORA L JNZ RD4 ; We've reached the end of the input file ; so, we ask for another one LXI H,Ifprn JMP IFR1 RD4 DCX H ;Got to get another SHLD IFS ;sector from disk LXI H,IFB SHLD IFP PUSH D XCHG LHLD IFA ;Get disk address INX H ;update for next time SHLD IFA ;and save DCX H ;back to the one we want PUSH B ;going to preserve B MVI B,1 ;Read LDA IFD ;Drive for input file MOV C,A ;into C MVI A,1 ;1 sector CALL Dio ;Get it POP B ;restore POP D ;this too JNC RD1 ;Now we can get another byte JMP Err Ofpr DB 'What''s the output file name? ',0 CK1 CPI 3 ;Now lets check JNZ Err ;for the 0503 error ADD D CPI 8 ;adds up to 8 JNZ Err ;No good! LXI H,Coutb SHLD OFR POP B ;VMPC POP H ;VMSP RET ; Ouputs jump to here Coutb PUSH H ;We're outputting to the consol LHLD TMStack MOV A,M CALL WH1 POP H RET OUTB PUSH H ;Save VMSP PUSH B ;Save VMPC LXI H,Ofpr ;get one from him. LXI D,FDB ;File descriptor buffer LXI B,'AI' ;('AI' is default ext) CALL Gf JNC Out2 XRA A ;Checks for error ADD E ;code 0300H or 0503H JNZ CK1 ;Does not return ADD D ;unless one was CPI 3 ;found. Sets CARRY JNZ Err ;Need to have ;a 0300 error LXI H,FDB ;We need to save this ;for close MOV A,M ANI 7 ;trim down to drive no. STA OFD ;Drive number INX H MOV A,M ;FDE flag byte ANI 1FH ;trim to file size ADI 3 ;point past extension MOV E,A ;Put into DE MVI D,0 DAD D ;Add to Address in HL XCHG ;FDA pointer now in DE LXI H,OFA ;Where the addresses go MVI C,4 ;4 bytes to copy COFD LDAX D ;Get the data MOV M,A ;from the FDB INX H ;and copy into the INX D ;areas for our Dio DCR C ;routines JNZ COFD ;More to copy LXI H,OFB ;Reset the SHLD OFP ;buffer pointer too LXI H,Outb ;characters thru SHLD OFR POP B ;VMPC POP H ;VMSP RET ; Routine to output to an open file ; thru calls to Outb Outb PUSH PSW ;For writing PUSH B PUSH D PUSH H LXI H,Ioret PUSH H LHLD TMStack ;Get the char MOV A,M ;The rest of this is called as a subroutine for ;filling up the last sector with zeros also. Store LHLD OFP MOV M,A ;put char in buffer LXI D,Flag LDAX D ORA A JNZ Store1 DCR A ;We've been had! STAX D Store1 INX H ;bump pointer SHLD OFP LXI D,OFB DCR H MOV A,H CMP D RNZ MOV A,L CMP E RNZ ;pointer now points at OFB so do DIO. SHLD OFP ;DE points at OFB LHLD OFS ;Number of sectors INX H ;One more SHLD OFS LHLD OFA ;Disk address INX H ;Up date for next time SHLD OFA DCX H ;Here's where we write LDA OFD ;Drive MOV C,A ;Drive no. MVI B,0 ;Write MVI A,1 ;one sector CALL Dio JC Err RET ; Routines for closing the file TURNOFF PUSH H ;Save VMSP PUSH B ;Save VMPC LDA Flag ;See if we're ;still Virgin. ORA A ;(Also for closing JZ TO1 ;a read file.) Fill LDA OFP ;Not virgin, CPI OFB AND 0FFH MVI A,0 JZ Close1 CALL Store ;fill up last sector JMP Fill ;with zeros Close1 LXI H,FDB+1 MOV A,M ANI 1FH ;strip down to length ADI 5 ;Point past ext and FDA MOV E,A MVI D,0 DAD D XCHG ;adr of DNS now in DE LHLD OFS XCHG MOV M,E INX H MOV M,D ;length now updated LXI H,FDB MOV A,M ANI 7FH MOV M,A MVI A,1 ;enter new output ;file in directory CALL Gf1 JC Err TO1 XRA A ;Virgin exit. STA Flag Out1 LXI H,OUTB ;Restore calling address SHLD OFR ;to open a file POP B ;VMPC POP H ;VMSP RET Origin hlt ;L0 MACRO instruction Origin DB 80H Pgmaddr EQU $ ; We load the executable file on top ;of the Start code !! Start LHLD MEMTOP SHLD TMStack LXI H,USER MVI M,RET ;Don't START again LHLD CMPTR ;Cmd pointer MOV A,M CPI CR JZ Out3 LXI D,FDB ;File descriptor block ;built by Gfid LXI B,4C30H ;L/0 extension for ;default is L0 MVI A,60H CALL Gf1 JC Out ;Something Wrong! LXI H,FDB MOV A,M ANI 7 ;Kill flags MOV M,A INX H ;Move up to FDE flags. MOV A,M ANI 1FH ;Kill flags ADI 3 ;Point past ext MOV E,A MVI D,0 DAD D ;Addr of FDA MOV E,M INX H MOV D,M INX H LDA FDB MOV C,A ;Drive to C MVI B,1 ;Read MOV A,M ;DNS XCHG ;FDA to HL LXI D,Pgmaddr ;Where to put it JMP GETP END