diff --git a/src/inc/sane.plh b/src/inc/sane.plh new file mode 100644 index 0000000..b017fc5 --- /dev/null +++ b/src/inc/sane.plh @@ -0,0 +1,135 @@ +import sane +//----------------------------------------------------------- +// Operation code masks. +//----------------------------------------------------------- +const FOADD = $0000 // add +const FOSUB = $0002 // subtract +const FOMUL = $0004 // multiply +const FODIV = $0006 // divide +const FOCMP = $0008 // compare, no exception from unordered +const FOCPX = $000A // compare, signal invalid if unordered +const FOREM = $000C // remainder +const FOZ2X = $000E // convert to extended +const FOX2Z = $0010 // convert from extended +const FOSQRT = $0012 // square root +const FORTI = $0014 // round to integral value +const FOTTI = $0016 // truncate to integral value +const FOSCALB = $0018 // binary scale +const FOLOGB = $001A // binary log +const FOCLASS = $001C // classify +const FONEXT = $001E // next-after +// +const FOSETENV = $0001 // set environment +const FOGETENV = $0003 // get environment +const FOSETHV = $0005 // set halt vector +const FOGETHV = $0007 // get halt vector +const FOD2B = $0009 // convert decimal to binary +const FOB2D = $000B // convert binary to decimal +const FONEG = $000D // negate +const FOABS = $000F // absolute value +const FOCPYSGN = $0011 // copy sign +// UNDEFINED = $0013 +const FOSETXCP = $0015 // set exception +const FOPROCENTRY = $0017 // procedure-entry +const FOPROCEXIT = $0019 // procedure-exit +const FOTESTXCP = $001B // test exception +// UNDEFINED = $001D +// UNDEFINED = $001F +//----------------------------------------------------------- +// Operand format masks. +//----------------------------------------------------------- +const FFEXT = $0000 // extended -- 80-bit float +const FFDBL = $0100 // double -- 64-bit float +const FFSGL = $0200 // single -- 32-bit float +// UNDEFINED = $0300 +const FFINT = $0400 // integer -- 16-bit integer +const FFCOMP = $0500 // comp -- 64-bit integer +// UNDEFINED = $0600 +// UNDEFINED = $0700 +//----------------------------------------------------------- +// Class. +//----------------------------------------------------------- +const FCSNAN = $FC // -4: signaling NAN +const FCQNAN = $FD // -3: quiet NAN +const FCINF = $FE // -2: infinite +const FCZERO = $FF // -1: zero +const FCNORM = $00 // 0: normal +const FCDENORM = $01 // 1: denormal +//----------------------------------------------------------- +// Exceptions. +//----------------------------------------------------------- +const FBINVALID = $01 +const FBUFLOW = $02 +const FBOFLOW = $04 +const FBDIVZER = $08 +const FBINEXACT = $10 +//----------------------------------------------------------- +// Elementary function operation code masks. +//----------------------------------------------------------- +const FOLNX = $0000 // base-e log +const FOLOG2X = $0002 // base-2 log +const FOLN1X = $0004 // ln (1 + x) +const FOLOG21X = $0006 // log2 (1 + x) +const FOEXPX = $0008 // base-e exponential +const FOEXP2X = $000A // base-2 exponential +const FOEXP1X = $000C // exp (x) - 1 +const FOEXP21X = $000E // exp2 (x) - 1 +const FOXPWRI = $0010 // integer exponentiation +const FOXPWRY = $0012 // general exponentiation +const FOCOMPND = $0014 // compound +const FOANNUIT = $0016 // annuity +const FOATANX = $0018 // arctangent +const FOSINX = $001A // sine +const FOCOSX = $001C // cosine +const FOTANX = $001E // tangent +const FORANDX = $0020 // random +//----------------------------------------------------------- +// NaN error codes. +//----------------------------------------------------------- +const NANSQRT = 1 // Invalid square root such as sqrt(-1). +const NANADD = 2 // Invalid addition such as +INF - +INF. +const NANDIV = 4 // Invalid division such as 0/0. +const NANMUL = 8 // Invalid multiply such as 0 * INF. +const NANREM = 9 // Invalid remainder or mod such as x REM 0. +const NANASCBIN = 17 // Attempt to convert invalid ASCII string. +const NANCOMP = 20 // Result of converting comp NaN to floating. +const NANZERO = 21 // Attempt to create a NaN with a zero code. +const NANTRIG = 33 // Invalid argument to trig routine. +const NANINVTRIG = 34 // Invalid argument to inverse trig routine. +const NANLOG = 36 // Invalid argument to log routine. +const NANPOWER = 37 // Invalid argument to x^i or x^y routine. +const NANFINAN = 38 // Invalid argument to financial function. +const NANINIT = 255 // Uninitialized storage. +//----------------------------------------------------------- +// +// Data types +// +struc t_single + byte[3] s_mantissa + byte s_exponent +end +struc t_double + byte[6] d_mantissa + word d_exponent +end +struc t_extended + byte[8] x_mantissa + word x_exponent +end +struc t_bigint + byte[8] l_int +end +// +// SANE PLASMA interface +// +struc t_sane + word fpInit + word fpOp1 + word fpOp2 + word elOp1 + word elOp2 + word zpSave + word zpRestore +end +word sane +end diff --git a/src/libsrc/sane.pla b/src/libsrc/sane.pla index b28e2a0..07c4fc5 100644 --- a/src/libsrc/sane.pla +++ b/src/libsrc/sane.pla @@ -12,17 +12,21 @@ struc t_codefile word[16] textaddr word[16] seginfo end - -export word[64] sane -byte ref -word pcode, fp6502, elems, preloc - -asm equates - !SOURCE "vmsrc/plvmzp.inc" -end +// +// External interface to SANE libraries +// +predef fpInit(), uninit0(), uninit1(op, dst), uninit2(op, dst, src) +export word[7] sane = @fpInit, @uninit1, @uninit2, @uninit1, @uninit2, @uninit0, @uninit0 +// +// Pointer to FP6502 entry +// +word fp6502, fpzpsave // // PLASMA <-> SANE interface routines // +asm equates + !SOURCE "vmsrc/plvmzp.inc" +end asm fpOp1(op, dst)#1 LDA ESTKH,X PHA @@ -43,7 +47,7 @@ asm fixupFP1 STY ESTKH,X RTS end -asm fpOp2(op1, dst, src)#1 +asm fpOp2(op, dst, src)#1 LDA ESTKH,X PHA LDA ESTKL,X @@ -68,154 +72,274 @@ asm fixupFP2 STY ESTKH,X RTS end -def prbyte(h)#0 - putc('$') - call($FDDA, h, 0, 0, 0) +asm elemsOp1(op, dst)#1 + LDA ESTKH,X + PHA + LDA ESTKL,X + PHA + LDA ESTKH+1,X + PHA + LDA ESTKL+1,X + PHA + INX + STX ESP end +asm fixupEL1 + JSR $FFFF + TXA + LDX ESP + STA ESTKL,X + STY ESTKH,X + RTS +end +asm elemsOp2(op, dst, src)#1 + LDA ESTKH,X + PHA + LDA ESTKL,X + PHA + LDA ESTKH+1,X + PHA + LDA ESTKL+1,X + PHA + LDA ESTKH+2,X + PHA + LDA ESTKL+2,X + PHA + INX + INX + STX ESP +end +asm fixupEL2 + JSR $FFFF + TXA + LDX ESP + STA ESTKL,X + STY ESTKH,X + RTS +end +asm zpSave#1 + LDY #$33 +- LDA $00,Y +end +asm fixupZPS + STA $FFFF,Y + DEY + BPL - + DEX + RTS +end +asm zpRestore#1 + LDY #$33 +end +asm fixupZPR +- LDA $FFFF,Y + STA $00,Y + DEY + BPL - +end +asm nopZP#1 + DEX + RTS +end +// +// Utility test routines +// +//def prbyte(h)#0 +// putc('$') +// call($FDDA, h, 0, 0, 0) +//end def prword(h)#0 putc('$') call($F941, h >> 8, h, 0, 0) end -def print(i)#0 - byte numstr[7] - byte place, sign +//def putname(pchr)#0 +// byte c +// +// for c = 0 to 7 +// putc(pchr->[c]) +// next +//end +//def putln#0 +// putc('\n') +//end +//def dumpheader(phdr)#0 +// byte i +// +// puts("Seg Info\n") +// for i = 0 to 15 +// if (phdr + i * t_diskinfo)=>codelen +// prword((phdr + i * t_diskinfo)=>codelen) +// putc(':') +// prword((phdr + i * t_diskinfo)=>codeaddr) +// putc('=') +// putname(phdr + i * 8 + segname) +// putc(',') +// prword((phdr + segkind)=>[i]) +// putc(',') +// prword((phdr + textaddr)=>[i]) +// putc(',') +// prword((phdr + seginfo)=>[i]) +// putln +// fin +// next +// putname(phdr + $01F4); putln +//end +// +// Fix-up external references and local relocations +// +def fixup(base, list) + word len + byte listcnt - place = 6 - if i < 0 - sign = 1 - i = -i - else - sign = 0 + //puts("Reloc = "); prword(list); putln + if *list <> $0101 + //puts("Reloc table not found!\n") + return list fin - while i >= 10 - numstr[place] = i % 10 + '0' - i = i / 10 - place = place - 1 + list = list - 10 + // + // External reference fixup (only have fp6502 in our case) + // + len = *list + list = list - 2 + //puts("Extern list len = "); prword(len); putln; getc + while len + //puts(" *"); prword(list - *list); putln + *(list - *list) = fp6502 + list = list - 2 + len-- loop - numstr[place] = i + '0' - place = place - 1 - if sign - numstr[place] = '-' - place = place - 1 - fin - numstr[place] = 6 - place - puts(@numstr[place]) -end -def putname(pchr)#0 - byte c - - for c = 0 to 7 - putc(pchr->[c]) - next -end -def putln#0 - putc('\n') -end -def dumpheader(phdr)#0 - byte i - - puts("Seg Info\n") - for i = 0 to 15 - if (phdr + i * t_diskinfo)=>codelen - prword((phdr + i * t_diskinfo)=>codelen) - putc(':') - prword((phdr + i * t_diskinfo)=>codeaddr) - putc('=') - putname(phdr + i * 8 + segname) - putc(',') - prword((phdr + segkind)=>[i]) - putc(',') - prword((phdr + textaddr)=>[i]) - putc(',') - prword((phdr + seginfo)=>[i]) - putln - fin - next - putname(phdr + $01F4); putln -end -def reloc(base, prel, ofst) - word listsz, list, len - - list = prel - while prel->1 == 1 - prel = prel - 2 - listsz = *prel - while listsz - prel = prel - 2 - if *prel - list = base + *prel - ofst - len = *list - list = list - 2 - puts("Reloc list len = "); prword(len); putln - while len - *(list - *list) = *(list - *list) + base - list = list - 2 - len-- - loop - fin - listsz-- - loop + // + // Internal relocation + // + len = *list + list = list - 2 + //puts("Reloc list len = "); prword(len); putln; getc + while len + //puts(" *"); prword(list - *list); putln + *(list - *list) = *(list - *list) + base + list = list - 2 + len-- loop return list end -def fixup(base, pli, preloc) - byte fixups - word basend - - puts("LinkInfo "); prword(pli); putc(':'); putln - basend = preloc - while ^pli - putname(pli); putc(':') - prword(pli=>8); putc(' ') - prword(pli=>10); putc(' ') - prword(pli=>12); putc(' ') - prword(pli=>14); putln - fixups = 0 - if pli=>8 == $0002 - fixups = pli=>12 - elsif pli=>8 == $0006 and pli=>10 == $0001 - basend = reloc(base, preloc, pli=>12) - fin - pli = pli + 16 - while fixups - *(base + *pli) = fp6502 - pli = pli + 2 - fixups-- - loop - loop -end +// +// Linker Information that we don't need +// +//def resolve(base, pli) +// byte fixups +// word basend +// +// puts("LinkInfo "); prword(pli); putc(':'); putln +// basend = preloc +// while ^pli +// putname(pli); putc(':') +// prword(pli=>8); putc(' ') +// prword(pli=>10); putc(' ') +// prword(pli=>12); putc(' ') +// prword(pli=>14); putln +// fixups = 0 +// if pli=>8 == $0002 +// fixups = pli=>12 +// fin +// pli = pli + 16 +// while fixups +// *(base + *pli) = fp6502 +// pli = pli + 2 +// fixups-- +// loop +// loop +//end +// +// Load Pascal CODE file +// def loadcode(codefile) byte ref - word pcode, preloc, pli + word pcode, seglen - puts(codefile); puts(":\n") + //puts(codefile); puts(":\n") pcode = 0 ref = open(codefile, sysbuf) if ref pcode = heapmark read(ref, pcode, 512) - dumpheader(pcode) - putname(pcode + segname + 8); putc('='); prword(pcode); putln - preloc = (pcode + t_diskinfo)=>codeaddr - read(ref, pcode, heapavail) + //dumpheader(pcode) + //putname(pcode + segname + 8); putc('='); prword(pcode); putln + seglen = read(ref, pcode, (pcode + t_diskinfo)=>codeaddr) close(ref) - pli = pcode + (preloc | 511) + 1 - preloc = pcode + preloc - 2 - puts("Reloc = "); prword(preloc); putln - heaprelease(fixup(pcode, pli, preloc)) // Set heap to beginning of relocation list + heaprelease(fixup(pcode, pcode + seglen - 2)) // Set heap to beginning of relocation list fin return pcode end -fp6502 = loadcode("FP6502.CODE") -if !fp6502 - puts("SANE library not found.\n") +// +// Load ELEMS6502 library +// +def loadElems + word elems + + elems = loadcode("ELEMS.CODE") + if !elems + puts("ELEMS library not found.\n") + return 0 + fin + (@fixupEL1)=>1 = elems + (@fixupEL2)=>1 = elems + sane[3] = @elemsOp1 + sane[4] = @elemsOp2 + return 1 +end +// +// Don't load ELEMS6502 until referenced +// +def elemsLoad1(op, dst)#1 + if loadElems + return elemsOp1(op, dst) + fin return -1 -fin -elems = loadcode("ELEMS.CODE") -if !elems - puts("ELEMS library not found.\n") +end +def elemsLoad2(op, src, dst)#1 + if loadElems + return elemsOp2(op, src, dst) + fin return -1 -fin -call(-151, 0, 0, 0, 0) -return 0 +end +// +// Load SANE library and fixup function pointers +// +def fpInit() + fp6502 = loadcode("FP6502.CODE") + if !fp6502 + puts("SANE library not found.\n") + return -1 + fin + fpzpsave = heapalloc($0033) + // + // Fixup calls in interface routines + // + (@fixupFP1)=>1 = fp6502 + (@fixupFP2)=>1 = fp6502 + (@fixupZPS)=>1 = fpzpsave + (@fixupZPR)=>1 = fpzpsave + sane[1] = @fpOp1 + sane[2] = @fpOp2 + sane[3] = @elemsLoad1 + sane[4] = @elemsLoad2 + sane[5] = @zpSave + sane[6] = @zpRestore +end +// +// Uninitialized placeholders of API +// +def uninit0() + puts("SANE not initialized\n") + return -1 +end +def uninit1(op, dst) + puts("SANE not initialized\n") + return -1 +end +def uninit2(op, dst, src) + puts("SANE not initialized\n") + return -1 +end done diff --git a/src/makefile b/src/makefile index f65ad41..a70e19e 100755 --- a/src/makefile +++ b/src/makefile @@ -19,6 +19,7 @@ FATWDSK = FATWRITEDSK\#FE1000 FATRDSK = FATREADDSK\#FE1000 FILEIO = FILEIO\#FE1000 SANE = SANE\#FE1000 +SANITY = SANITY\#FE1000 WIZNET = WIZNET\#FE1000 UTHERNET2= UTHERNET2\#FE1000 UTHERNET= UTHERNET\#FE1000 @@ -63,7 +64,7 @@ TXTTYPE = .TXT #SYSTYPE = \#FF2000 #TXTTYPE = \#040000 -all: $(PLASM) $(PLVM) $(PLVM01) $(PLVM02) $(PLVM03) $(CMD) $(ARGS) $(MEMMGR) $(MEMTEST) $(FIBER) $(SB) $(MON) $(ROD) $(SIEVE) $(UTHERNET2) $(UTHERNET) $(ETHERIP) $(INET) $(DHCP) $(HTTPD) $(ROGUE) $(ROGUEMAP) $(ROGUECOMBAT) $(ROGUEIO) $(HGR1) $(TONE) $(DGR) $(DGRTEST) $(FILEIO) $(PORTIO) $(SPIPORT) $(SDFAT) $(FATCAT) $(FATGET) $(FATPUT) $(FATWDSK) $(FATRDSK) $(SANE) +all: $(PLASM) $(PLVM) $(PLVM01) $(PLVM02) $(PLVM03) $(CMD) $(ARGS) $(MEMMGR) $(MEMTEST) $(FIBER) $(SB) $(MON) $(ROD) $(SIEVE) $(UTHERNET2) $(UTHERNET) $(ETHERIP) $(INET) $(DHCP) $(HTTPD) $(ROGUE) $(ROGUEMAP) $(ROGUECOMBAT) $(ROGUEIO) $(HGR1) $(TONE) $(DGR) $(DGRTEST) $(FILEIO) $(PORTIO) $(SPIPORT) $(SDFAT) $(FATCAT) $(FATGET) $(FATPUT) $(FATWDSK) $(FATRDSK) $(SANE) $(SANITY) clean: -rm *FE1000 *FF2000 $(PLASM) $(PLVM) $(PLVM01) $(PLVM02) $(PLVM03) @@ -180,6 +181,10 @@ $(SANE): libsrc/sane.pla $(PLVM02) $(PLASM) ./$(PLASM) -AMO < libsrc/sane.pla > libsrc/sane.a acme --setpc 4094 -o $(SANE) libsrc/sane.a +$(SANITY): samplesrc/sanity.pla $(PLVM02) $(PLASM) + ./$(PLASM) -AMO < samplesrc/sanity.pla > samplesrc/sanity.a + acme --setpc 4094 -o $(SANITY) samplesrc/sanity.a + $(TONE): libsrc/tone.pla $(PLVM02) $(PLASM) ./$(PLASM) -AMO < libsrc/tone.pla > libsrc/tone.a acme --setpc 4094 -o $(TONE) libsrc/tone.a diff --git a/src/samplesrc/sanity.pla b/src/samplesrc/sanity.pla new file mode 100644 index 0000000..af178d6 --- /dev/null +++ b/src/samplesrc/sanity.pla @@ -0,0 +1,33 @@ +// +// SANE library test program +// +include "inc/cmdsys.plh" +include "inc/sane.plh" +// +// Test values +// +word iA, iB, iC +byte xT[t_extended] + +def puti(i) + if i < 0; putc('-'); i = -i; fin + if i < 10 + putc(i + '0') + else + puti(i / 10) + putc(i % 10 + '0') + fin +end + +iA = 3 +iB = 4 +iC = -1 +puts("SANE sanity test...\n") +sane.fpInit() +sane:zpSave() +sane:fpOp2(FFINT|FOZ2X, @xT, @iA) // Convert int A to ext T +sane:fpOp2(FFINT|FOADD, @xT, @iB) // Add int B to ext T +sane:fpOp2(FFINT|FOX2Z, @iC, @xT) // Convert ext T to int C +sane:zpRestore() +puti(iA); putc('+'); puti(iB); putc('='); puti(iC); putc('\n') +done