IMD 1.17: 14/03/2012 8:58:23 KEYS: B3466A 3.5" DS      KEYS  M MAKE_KEYSTK  I NONUSKBD1TK RhKEYST_____K/O WNBATT______K~   4A804XDVRT_KP O|CLOCKT____K NONUSKBD2TK ABST______K RELT______K3, !+KERNELT___K_ 0COMASMT___K  8COMDCLT___K  BALLREALST_K !%MOREFSYST_Km: !9!REVASMT___Kړ !!DEBUGGERT_K !A%INITBUGT__KpE !HDCONVERTT__K  !Q ASCIIT____K" !V!UCSD_AMT__K  "READMET___  "4READMET___K YT ****************************************************************** * STREAM FILE FOR MISC INITLIB STUFF ...... ********************** ****************************************************************** cASCII n cUCSD_AM n cCONVERT n cINITBUG n cREVASM n aDEBUGGER n cMOREFSYS n aALLREALS n cKERNEL n aCOMASM n cABS n cREL n cKEYS n cBAT n cCLOCK n cA804XDVR n cNONUSKBD1 n cNONUSKBD2 n ***************************************************************** * NOW LINK EM ........ ****************************************** ***************************************************************** loA804XDVR. lnA804XDVR x Copyright Hewlett-Packard Co.,1982,1991 All rights reserved. iA804XDVR alkq loKEYS. lnKEYS dx Copyright Hewlett-Packard Co.,1982,1991 All rights reserved. iKEYS alkq loNONUSKBD1. lnNONUSKBD1 dx Copyright Hewlett-Packard Co.,1984,1991 All rights reserved. iNONUSKBD1 alkq loNONUSKBD2. lnNONUSKBD2 dx Copyright Hewlett-Packard Co.,1984,1991 All rights reserved. iNONUSKBD2 alkq loBAT. lnBAT dx       (* (c) Copyright Hewlett-Packard Company, 1984. All rights are reserved. Copying or other reproduction of this program except for archival purposes is prohibited without the prior written consent of Hewlett-Packard Company. RESTRICTED} t1['0.,+123-456*789/E()^1234567890'''#170#200'&'#197#203',.-', '0.|~123`456@789\<[]>!"#$%+/()=?'#171#181'*'#201#179';:_'], { german } t1['0.,+123-456*789/E()^1234567890'#222''''#207'+'#206#204',.-', '0.|~123'#179'456@789\<[]>!"#$%&/()=?`'#21 RIGHTS LEGEND Use, duplication, or disclosure by the Government is subject to restrictions as set forth in paragraph (b) (3) (B) of the Rights in Technical Data and Computer Software clause in DAR 7-104.9(a). HEWLETT-PACKARD COMPANY Fort Collins, Colora9'*'#218#216';:_'], { swedish/finish } t1['0.,+123-456*789/E()^1234567890+'#197#212#207#206#204',.-', '0.|~123''456@789\<[]>!"#$%&/()=?'#220#208#219#218#216';:_'], { spanish } t1['0.,+123-456*789/E()^1234567890+'#168#179'#'#183'*,.-', '0.|+12Copyright Hewlett-Packard Co.,1982,1991 All rights reserved. iBAT alkq loCLOCK. lnCLOCK dx Copyright Hewlett-Packard Co.,1982,1991 All rights reserved. iCLOCK alkq lh1 oDGL_ABS. lnDGL_ABS dx Copyright Hewlett-Packard Co.,1985,1991 All rights reserved. iAdo *) $SYSPROG$ $heap_dispose off$ $iocheck off$ $range off$ $ovflcheck off$ $debug off$ $stackcheck off$ program NONUS1INIT; module NON_US_KBD1; import sysdevs,misc; export function initlang:boolean; implement procedure kataBS alkq lh1 oDGL_REL. lnDGL_REL dx Copyright Hewlett-Packard Co.,1985,1991 All rights reserved. iREL alkq loIODECLARATIONS. lnIODECLARATIONS x Copyright Hewlett-Packard Co.,1982,1991 All rights reserved. iKERNEL aiCOMASM alkq loREALS. lnREALS x Copyrighkanatrans; label 1; { katakana language keycode->character code translations } begin {katakanatrans} if langcom.status=0 then langcom.result:=alpha_key else if langcom.data>127 then langcom.result:=ignored_key else with langcom, langtable[0]^, kt Hewlett-Packard Co.,1982,1991 All rights reserved. iALLREALS aiMOREFSYS alkq lh1 oREVASM. lnREVASM x Copyright Hewlett-Packard Co.,1983,1991 All rights reserved. iREVASM alkq lh1 oDEBUGGER. lnDEBUGGER x Copyright Hewlett-Packard Co.,1982,1991 All righteytable[data] do begin result := keyclass; if (result=ignored_key) and not kbdaltlock then goto 1; if (data=18) or (data=19) then { change to/from alternate } begin result:=ignored_key; kbdaltlock:=(data=18); end else s reserved. diDEBUGGER aiINITBUG alkq loASC_AM. lnASC_AM x Copyright Hewlett-Packard Co.,1982,1991 All rights reserved. diASCII alkq loCONVERT. lnCONVERT_TEXT x Copyright Hewlett-Packard Co.,1982,1991 All rights reserved. iCONVERT alkq loTEXT_AM. lnTEXTif control and (kbdtype<>ITFKBD) and ((data=96) or (data=97)) then { change to/from alternate } begin result:=ignored_key; kbdaltlock:=(data=96); end else if kbdaltlock then begin { use alternate language } langin_AM dx Copyright Hewlett-Packard Co.,1982,1991 All rights reserved. iUCSD_AM alkq ******************************************************************* * DONE BUILDING AND LINKING MISCELLANEOUS INITLIB MODULES ********* *************************************dex:=1-langindex; extension:=false; call(langtable[langindex]^.semantics); langindex:=1-langindex; end else if result<>ignored_key then begin { normal processing } extension := false; shift:= shift and not no_shift; ******************************  key := keys[shift]; end; end; { with langcom etc. } 1:end; {katakanatrans} function initlang:boolean; type t1 = packed array[boolean, 60..98] of char; t2 = packed array[FRENCH_KBD..KATAKANA_KBD] of t1; const keylookup = t2[ {french     3''456*789\<[]>!"'#185'$%&'#184'()=?/{}'#182'@;:_'], { katakana } t1[ '0.,+123-456*789/E()^'#199#204#177#179#180#181#212#213#214#220#206#205#209#219#218#185#200#217#210, '0.,+123-456*789/`|\~'#199#204#167#169#170#171#172#173#174#166#176#205#222#223#218#pslock key } if kbdtype=ITFkbd then begin { changes to keys 1, 2, 92 and 93 } keytable[1].keys[false]:=#219; keytable[1].keys[true]:=#176; keytable[2].keys[false]:=#209; keytable[2].keys[true]:=#163; keytable[92].keys[false]:=#222; keytable[185#164#161#165] ]; { KATAKANA TABLE IS NIMITZ BASED AS IN 2.x - MODS LATER IN CODE } { end of keylookup } type k2 = packed array [100..125] of 0..255; bytealphabettype = packed array [boolean] of k2; const yencode=92; kanaalphabet = byte92].keys[true]:=#222; keytable[93].keys[false]:=#223; keytable[93].keys[true]:=#162; end; IF (KBDTYPE = SMALLKBD) OR (KBDTYPE = LARGEKBD) THEN { RQ/SFB 5/11/84 } WITH LANGTABLE[1]^ DO BEGIN KEYTABLE[92].KEYS[TRUE] := '\'; KEYTABLE[93].KEalphabettype [k2[ 215,190,201,216,192,195,178,189,182,221,197,198, 193,196,188,202,183,184,207,211,194,187,191,203, 186,208 ], k2[ 215,190,201,216,192,195,168,189,182,221,197,198, 193,196,188,202,183,184,207,211,175,187,191,20YS[TRUE] := '|'; END; for i:=0 to 127 do keytable[i].no_capslock:=true; end; case kbdlang of german_kbd,swedish_kbd: begin keytable[92].no_capslock:=false; keytable[94].no_capslock:=false; keytable[95].no_capslock:=false; 3, 186,208]]; var i : -32768..32767; begin if (kbdlang=katakana_kbd) or (((kbdtype=largekbd) or (kbdtype=smallkbd)) and ((kbdlang>=french_kbd) and (kbdlang<=spanish_kbd))) and (langtable[0]<>nil) then if (langtable[0]^.langc if kbdlang=german_kbd then begin keytable[120]:=keytable[109]; {z<=y} keytable[109].keys[false]:='z'; keytable[109].keys[true ]:='Z'; end else begin { swedish_kbd } keytable[91].no_capslock:=false; keytable[93].no_code=us_kbd) then begin initlang := true; with langtable[0]^ do begin { extend char keys don't exist on non ITF keyboards } { and katakana wants pass thru mode } transmode := kpass_extc; langcode := kbdlang; if apslock:=false; end; end; spanish_kbd: BEGIN { 5/10/84 SFB } keytable[94].no_capslock:=false; KEYTABLE[91].KEYCLASS:=NONA_ALPHA_KEY; { 5/11/84 SFB } END; FRENCH_KBD : KEYTABLE[91].KEYCLASS:=Nkbdlang=katakana_kbd then { 5/14/84 RQ/SFB} begin if langtable[1]=nil then new(langtable[1]); langtable[1]^:=langtable[0]^; { copy the us table } end; for i:=60 to 98 do { MOVED 5/14/84 RQ/SFB} begin { special alpha lONADV_KEY; { 5/11/84 SFB } otherwise end; { case } langindex:=0; kbdcapslock:=true; kbdaltlock:=(kbdlang=katakana_kbd); end; { with langtable[0]^ } end { if my kind of keyboard } else initlang:=false; end; {initlangoading } keytable[i].keys[false]:=keylookup[kbdlang,false,i]; keytable[i].keys[true] :=keylookup[kbdlang,true,i]; end; keytable[99].keys[false]:=' '; keytable[99].keys[true]:=' '; if kbdlang=katakana_kbd then begin semantics := } end; { module nonitflang } import NON_US_KBD1, loader; begin if initlang then markuser; end. katakanatrans; can_nonadv:= false; for i:=100 to 125 do begin { load alpha keys } keytable[i].keys[false]:=chr(kanaalphabet[false,i]); keytable[i].keys[true] :=chr(kanaalphabet[true,i]); end; keytable[24].keyclass:=ignored_key; { ignore ca (* (c) Copyright Hewlett-Packard Company, 1984. All rights are reserved. Copying or other reproduction of this program except for archival purposes is prohibited without the prior written consent of Hewlett      length, position: integer); var interruptlevel: integer; commandinprogress: char; zchr: char; buf: charptr; begin ioresult := ord(inoerror); buf := addr(buffer); case request of flush: {do nothing } if request = startread then call(fp^.feot, fp); end; otherwise ioresult := ord(ibadrequest); end; end; { dokbdio } procedure nonadvkeys; type aa = packed array['' .. ''] of char; const ala = aa['']; { tables modified/widened }; unitstatus: fp^.fbusy := keybuffer^.size = 0; clearunit: begin interruptlevel := intlevel; if interruptlevel <1 then setintlevel(1); keybufops(kclear,zchr); { clear typeahead buffer } 5/7/84 SFB/RQ } ale = aa['e']; ali = aa['i']; alo = aa['']; alu = aa['u']; aly = aa['yyy']; { added for 3.1--SFB--5/21/85 } aua = aa['ࡢ']; aue = aa['ܣE']; aui = aa['榧I']; auo = aa['']; auu = aa['-Packard Company. RESTRICTED RIGHTS LEGEND Use, duplication, or disclosure by the Government is subject to restrictions as set forth in paragraph (b) (3) (B) of the Rights in Technical Data and Computer Software clause in DAR 7-104.9(a). HE setintlevel(interruptlevel); end; $if false$ writeeol, startwrite, writebytes: crtio(fp, request, buffer, length, 0); $end$ readtoeol, readbytes, startread: begin if request = readtoeol then begin buf := addWLETT-PACKARD COMPANY Fort Collins, Colorado *) $MODCAL $ $heap_dispose off$ $iocheck off$ $range off$ $ovflcheck off$ $debug off$ $STACKCHECK OFF$ { $SEARCH 'INITLOAD','ASM','INIT', 'SYSDEVS'$ } program keysinit; module keys; ir(buf^, 1); { format buffer as a string } buffer[0] := chr(0); end; while length>0 do begin {if runlight<>chr(idle) then} {bugfix 5/8/85 SFB} commandinprogress := runlight; interruptlevel := intlevel; with keybufmport sysglobals, asm, misc, sysdevs; export procedure initkeys; implement const sysnorm = string80['| k0 |RECALL |CLR-END| CONT | | STEP | ALPHA | GRAPH | k9 |']; sysshft = string80['| k0 |RECALL |CLR-END| CONT | |ANYCHAR| Dfer^ do repeat while size = 0 do call(kbdwaithook); { wait for keys } setintlevel(7); {disable interrupts} if size = 0 then setintlevel(interruptlevel); until size > 0; setrunlight(commandinprogress); wMP A | DMP G | k9 |']; type menu1 = array[boolean] of menutype; menu2 = array[m_none..m_sysshift] of menu1; const mstates = menu2[ { no menu } menu1[m_sysnorm,m_sysshift], { normal } menu1[m_none,m_sysshiftith keybuffer^ do buf^:=buffer^[outp]; { BUG FIX #64 } if buf^ = chr(etx) then length := 0 else length := length-1; if (buf^=eol) and (request=readtoeol) then length := 0 else begin keybufops(kgetchar,], { shifted } menu1[m_sysnorm,m_none]]; var anychar : boolean; buildchar : shortint; buildcount : 0..4; anycharsavehook : kbdhooktype; procedure stopaction; begin actionspending := 0; escape(-20); end; procedure buf^); { get next character from input } { BUG FIX #64 } fp^.feoln := false; { set not end of line } buf := addr(buf^, 1); { increment output buffer address } if request = readtocntrlpausekey; type strin = string[1]; const qm = strin['?']; begin call(debugger,4,integer(addr(qm)),0) end; procedure pausekey; begin call(debugger,6,0,0) end; procedure dokbdio(fp: fibp; request: amrequesttype; anyvar buffer: window; eol then buffer[0] := chr(ord(buffer[0])+1); { increment string size } end; setintlevel(interruptlevel); { restore interrupt level} { BUG FIX #64 } end; { while     U']; auy = aa['YYY']; { added for 3.1--SFB--5/21/85 } var nc : char; begin nc := keybuffer^.non_char; if langtable[langindex]^.can_nonadv and (nc<>' ') then begin if (langcom.key=rightchar) or (langcom.key=' ') then langcom.key:=nc  tshift := (kbdcapslock and not no_capslock) <> shift; key := keys[tshift]; if (result=alpha_key) and control then key := chr(ord(key) mod 32); if result=alpha_key then nonadvkeys ; { 5/21/84 SFB else if result=spec else case langcom.key of {mods to add accented y,Y--SFB--5/21/85} 'a': langcom.key := ala[nc]; 'e': langcom.key := ale[nc]; 'i': langcom.key := ali[nc]; 'o': langcom.key := alo[nc]; 'u': langcom.key := alu[nc]; ial_key then if (not tshift and not control and (key=rightchar)) then begin result:=alpha_key; nonadvkeys; end; { 5/9/84 RQ/SFB } end; end; { with langcom etc } 1:end; { generaltrans } procedure initlang; type alphatype =  'y': langcom.key := aly[nc]; { changed for 3.1--SFB--5/21/85 } 'n': if nc = '' then langcom.key := ''; 'A': langcom.key := aua[nc]; 'E': langcom.key := aue[nc]; 'I': langcom.key := aui[nc]; { SFB/RQ 5/7/84 packed array[boolean, 100..125] of char; aspecialtype = packed array[boolean, 60..99] of char; b26 = packed array [100..125] of byte; bytealphabettype = packed array [boolean] of b26; const alphabet = alphatype['opklqwertyuiasdfghjmzxcv} 'O': langcom.key := auo[nc]; 'U': langcom.key := auu[nc]; 'Y': langcom.key := auy[nc]; { changed for 3.1--SFB--5/21/85 } 'N': if nc = '' then langcom.key := ''; otherwise end; {case key} keybuffer^.non_char:=bn', 'OPKLQWERTYUIASDFGHJMZXCVBN']; {shifted} us = aspecialtype['0.,+123-456*789/E()^1234567890-=[];'',./ ', '0.,+123-456*789/`|\~!@#$%^&*()_+{}:"<>? ']; {shifted} romanspecials = aspecialtype[ '0.,+ ' '; end; end; {nonadvkeys} procedure generaltrans; { multi lingual translate procedure } { all languages except katakana } label 1; var tshift : boolean; begin if langcom.status=0 then begin { check key for non advanced key involvement }123-456*789/E()^'#184#64#35#247#248'^\[]'#246#254'|'#96'<>_ ', '0.,+123-456*789/`|\~'#184#64#35#247#248'^\{}'#176#254'|'#39'<>_ ']; { ABOVE LINE MODIFIED TO GIVE SHIFT-EXTEND 6 AS ^, NOT | 5/7/84 SFB } romanalphabet = bytealphabettype  if (langcom.key>=#168)and(langcom.key<=#172) then langcom.result:=nonadv_key else begin langcom.result:=alpha_key; nonadvkeys; end; end else { process key code } if langcom.data>127 then langcom.result:=ignored_key else with la [b26[214,241,191,187,000,126,215,168,169,170,171,172,212, 222,228,190,186,188,036,250,000,236,181,189,252,249], b26[210,240,191,187,000,126,211,168,169,170,171,172,208, 222,227,190,186,1ngcom, langtable[langindex]^, keytable[data] do begin result := keyclass; if result=ignored_key then goto 1; extension := extension and not no_extension; if extension then begin { call alternate semantics routine } extension:=fa88,036,250,000,235,180,189,252,249]]; var i : shortint; krec : langkeyrec; begin if langtable[0]=nil then new(langtable[0]); with langtable[0]^ do begin langcode := us_kbd; semantics := generaltrans; { default translator } can_nolse; langindex:=1-langindex; { 0->1 or 1->0 } call(langtable[langindex]^.semantics); langindex:=1-langindex; end else begin { normal processing } control:= control and not no_control; shift := shift and not no_shift; nadv:= true; kbdcapslock := true; kbdaltlock := false; transmode:=kshift_extc; krec.no_capslock:=true; krec.no_shift :=false; krec.no_control :=false; krec.no_extension:=false; krec.keyclass :=alpha_key; { key code     n keyboard } langcode:=roman8_kbd; keytable[1].keys[false]:=#251; keytable[1].keys[true]:=#253;{<<,>>} for i:=60 to 125 do begin if i>=80 then keytable[i].no_capslock:=true; with keytable[i] DO if i>=100 thena; begin done := true; if not alphastate then call(togglealphahook) else if graphicstate then call(togglegraphicshook); end; procedure moregraphics; begin done := true; if not graphicstate then call(togglegrap begin { normal alpha keys } keys[false]:=chr(romanalphabet[false,i]); keys[true]:= chr(romanalphabet[true,i]); end else begin { special alpha keys } keys[false]:=romanspecials[false,i]; hicshook) else if alphastate then call(togglealphahook); end; procedure dumpalpha; begin done := true; lockedaction(dumpalphahook); end; procedure dumpgraphics; begin done := true; lockedaction(dumpgraphicshook); end; s 1..3 } krec.keys[false]:='`'; krec.keys[true]:='~'; keytable[1]:=krec; krec.keys[false]:='\'; krec.keys[true]:='|'; keytable[2]:=krec; krec.keys[false]:=#27; krec.keys[true]:=#127; {esc, del} keytable[3]:=krec; keytable[3].no_ keys[true]:= romanspecials[true,i]; end; end; { mark non advanceing keys } for i:=107 to 111 do keytable[i].keyclass:=nonadv_key; { ignore some keys } keytable[002].keyclass:=ignored_key; keytable[104].kextension:=true; keytable[2].no_control:=true; for i:=60 to 125 do begin if i>=100 then begin { normal alpha keys } if i=100 then krec.no_capslock:=false; krec.keys[false]:=alphabet[false,i]; krec.keys[true]:=alphabeyclass:=ignored_key; keytable[120].keyclass:=ignored_key; { cancel extension interpretation on all keys } for i:=0 to 127 do keytable[i].no_extension:=true; end; { with langtable[1] } end; { if ITF keyboard } end; {initlang} et[true,i]; end else begin { special alpha keys } krec.keys[false]:=us[false,i]; krec.keys[true]:=us[true,i]; end; keytable[i]:=krec; end; { un_implemented key codes } keytable[0].keyclass:=ignored_key procedure clearanychar; begin if anychar then begin anychar := false; kbdisrhook := anycharsavehook; end; end; { clearanychar } procedure rpghandler(var kbdstatus, kbddata: byte; var dokey: boolean); var key: char; begin { only store the ke; keytable[4].keyclass:=ignored_key; keytable[126].keyclass:=ignored_key; keytable[127].keyclass:=ignored_key; krec.keyclass:=special_key; krec.no_shift:=false; krec.no_control:=false; krec.no_capslock:=true; krec.no_extension:=true; y if the typeahead buffer is empty } if dokey then {3.0 BUGFIX SFB 5/1/85} begin case kbdstatus div 16 of 14: {shifted} if kbddata >= 128 then key:=chr(lf) else key:=chr(us); 15: {unshifted} if kbddata >= 128 then  for i:=5 to 59 do begin { special function keys } krec.keys[false]:=chr(i); krec.keys[true]:=chr(i); keytable[i]:=krec; end; { rightchar(fsp) involved in non advanceing keys } keytable[39].keys[false]:=rightchar; keytabkey:=chr(fsp) else key:=chr(bs); otherwise { ignore if control key down } beep; key := ' '; end; if (keybuffer^.size=0) and (key<>' ') then begin keybufops(kappend,key); clearanychar; call(kbdreleasehook); { sle[39].keys[true]:=rightchar; end; { with langtable[0] } if kbdtype=itfkbd then begin if langtable[1]=nil then new(langtable[1]); langtable[1]^:=langtable[0]^; { copy US to alternate } with langtable[1]^ do begin { load romaignal non empty buffer } end; end; {if dokey} end; { rpghandler } procedure keyservice(var kbdstatus, kbddata: byte; var dokey: boolean); label 1; var done: boolean; small: boolean; i : shortint; c : char; procedure morealph      procedure unrecognized; begin done := true; beep; end; procedure remove(all:boolean); var dummykey: char; begin if keybuffer^.size>0 then begin if all then keybufops(kclear,dummykey) else keybufopsshift then menustate:=m_none; menustate:=mstates[menustate,shift]; keybuffer^.echo:=(menustate=m_none); case menustate of m_none : keybufops(kdisplay,c); m_sysnorms(kgetlast,dummykey); { pop last char } end else beep; done:=true; end; { remove } procedure debugkey; begin call(debugger,3,langcom.status,langcom.data); end; begin { keyservice } if dokey then with langcom do begin : call(crtllhook,clldisplay,sysmenu^,c); m_sysshift: call(crtllhook,clldisplay,sysmenushift^,c); otherwise end; done := true; end else unrecognized;  done := false;{done indicates that key is handled immediately} status := kbdstatus; data := kbddata; extension:= not odd(kbdstatus div 8); shift := not odd(kbdstatus div 16); control := not odd(kbdstatus div 32); if not end; 22:if control then remove(true) else key:=chr(del);{ clear line } 23:if control then remove(true) else key:=chr(ff); { clear display } 24:begin KBDCAPSLOCK := not KBDCAPSLOCK; done := true end; 9,25:  odd(status) then begin result:=alpha_key; key:=chr(data); end else call(langtable[langindex]^.semantics); case result of alpha_key, { don't do anything yet } nonadv_key,{ have non advanceing key } nona_alpha_key: (* 3.01 BUG FI key := chr(tab); {tab} 34: key := chr(lf); {down arrow} 35: key := chr(us); {up arrow} {left arrow, backsX 9/19/84 SFB-JWS *); special_key: begin { decode special function keys } small := kbdtype=smallkbd; case data of 17: if control and not shift then unrecognized {enter/print} else if shift and control thpace} 38,46: if control then remove(false) else key := chr(bs); 39:BEGIN {SFB 5/21/84} key := chr(fsp); STATUS:=0; CALL(LANGTABLE[LANGINDEX]^.SEMANTICS);END; {right arrow} 40,43: key := 'I'; en dumpgraphics else if shift then dumpalpha else key:=chr(cr); {enter} 20:begin {system/user} if shift then key:='U' else key:='S'; kbdsysmode:=not shift; se {insert mode} 41: if small then moregraphics else key := 'D'; {delete mode} 42: if shift and small then morealpha else unrecognized; tstatus(6,key); if key='U' then if (menustate=m_sysnorm) or (menustate=m_sysshift) then begin menustate:=m_none; keybuffer^.echo:=true; keybufops(kdis {recall} 44: key := 'D'; {delete mode} 47: key := 'R'; {RUN key} 48: key := 'E'; {EDIT key} 49: if shift then dumpaplay,c); end; done:=true; end; 21:begin {menu} if kbdsysmode then begin call(crtllhook,cllclear,i,c); { clear display } if menustate>m_sylpha else morealpha; 50: if shift then dumpgraphics else moregraphics; 51: begin {STEP} {ANYCHAR} done := true; if shift then begin anychar:=true;       else if shift then key := chr(esc) {escape} else key := chr(etx); {EXECUTE} otherwise unrecognized; {no such code} end;{ case data } end;{ decode special function keys }  (* (c) Copyright Hewlett-Packard Company, 1983. All rights are reserved. Copying or other reproduction of this program except for archival purposes is prohibited without the prior written consent of Hewlettignored_key: goto 1;{ ignore this key } end;{ case langcom.result } if anychar then begin if done then begin { special key except ANYCHAR terminates ANYCHAR } if not (shift and (data = 51)) then clearanychar; end -Packard Company. RESTRICTED RIGHTS LEGEND Use, duplication, or disclosure by the Government is subject to restrictions as set forth in paragraph (b) (3) (B) of the Rights in Technical Data and Computer Software clause in DAR 7-104.9(a). HE anycharsavehook := kbdisrhook; kbdisrhook := keyservice; buildcount := 1; buildchar:= 0; end else debugkey;  else begin if (key < '0') or (key > '9') then begin clearanychar; unrecognized; end else begin buildchar:=buildchar*10+(ord(key)-ORD('0')); buildcount:=buildcount+1; done := buildcou{STEP key} end; 52: if control then remove(true) else if shift then key := chr(ff) {clear screen} else key := chr(del); {clear line} 53: if shift and small then dumnt <= 3; if not done then begin clearanychar; key:=chr(buildchar mod 256); status:=0; call(langtable[langindex]^.semantics); end; end; end; end; { anychar } if not donpalpha else unrecognized; {result, set tab} 54: if shift and small then dumpgraphics else unrecognized; {prt all, clr tab} e then begin if keybuffer^.size>=keybuffer^.maxsize then beep { no room in buffer } else if (result=nonadv_key) OR ((result=nona_alpha_key) and not shift) then keybufops(knonadvance,key) { 3.01 BUG FIX 9/19/84 SFB/JWS}  6,55: begin {stop} {clear I/O} done := true; clearanychar; lockedaction(stopaction); end; 5,56: begin {pause}  else begin keybufops(kappend,langcom.key); call(kbdreleasehook); end; end; { not done } end; { with langcom } 1:end; { keyservice } procedure dummykbdwait; begin setrunlight(chr(idle)); end; procedure initkeys; begin kbdwaithook := d done := true; data:=56; { change 5 to 56 } if locklevel = 0 then debugkey else if control then lockedaction(cntrlpausekey) else lockedaction(pausekey); end; ummykbdwait; kbdisrhook := keyservice; rpgisrhook := rpghandler; kbdiohook := dokbdio; anychar := false; sysmenu := addr(sysnorm); sysmenushift := addr(sysshft); initlang; KBDSETUP(SET_AUTO_REPEAT,4); {auto repeat period = 40 ms}  8,57: key := chr(cr); {ENTER} 58: begin done := true; debugkey; end; 7,59: {EXECUTE key} if control then key := chr(cntrl) {'control' char} KBDSETUP(SET_AUTO_DELAY,30); {auto repeat delay = 300 ms} SETRPGRATE(1); {rpg interupt rate = 10 ms} end; { initkeys } end; { module keys } import keys, loader; begin initkeys; markuser; end.      WLETT-PACKARD COMPANY Fort Collins, Colorado *) $modcal$ $heap_dispose off$ $iocheck off$ $range off$ $ovflcheck off$ $debug off$ $STACKCHECK OFF$ { $SEARCH 'INITLOAD','ASM','INIT','SYSDEVS'$ } program initbat(OUTPUT); module b(* (c) Copyright Hewlett-Packard Company, 1986. All rights are reserved. Copying or other reproduction of this program except for archival purposes is prohibited without the prior written consent of Hewlett-Packard Company. RESTRICTED RIGHat; import sysglobals, sysdevs; export procedure batinit; implement type statustype = packed record case integer of 0:(pad1 :0..63; busy :boolean; ready :boolean); TS LEGEND Use, duplication, or disclosure by the Government is subject to restrictions as set forth in paragraph (b) (3) (B) of the Rights in Technical Data and Computer Software clause in DAR 7-104.9(a). HEWLETT-PACKARD COMPANY Fort Collins, Colorado  1:(statbyte :byte); END; var bat8041statusreg[4554785 { 458001 } ]: char; bat8041cmdreg [4554785 { 458001 } ]: char; bat8041datareg [4554753 { 458021 } ]: char; procedure wait4batready; var batstatus: statustype; begin *) $SYSPROG$ $heap_dispose off$ $iocheck off$ $range off$ $ovflcheck off$ $debug off$ $stackcheck off$ $ALLOW_PACKED ON$ {JWS 3/31/87 } PROGRAM A804XINIT(OUTPUT); MODULE A804XDVR; { $SEARCH 'INITLOAD','ASM','SYSDEVS','INIT'$ } IM repeat batstatus.statbyte:=ord(bat8041statusreg); until not batstatus.busy; end; procedure wait4batreadready; var batstatus: statustype; begin repeat batstatus.statbyte:=ord(bat8041statusreg); until batstatus.ready; end; procedure dobatcPORT SYSGLOBALS,SYSDEVS,ISR,ASM; EXPORT TYPE DATAHOOKTYPE = PROCEDURE(DATA:BYTE); VAR DATAHOOK : DATAHOOKTYPE; STATUS5HOOK : KBDHOOKTYPE; STATUS6HOOK : KBDHOOKTYPE; PROCEDURE SENDCMD(CMD:BYTE); PROCEDURE SENDDATA(DATA:BYTE); PROCEDURE CMD_REommand(cmd: byte; numdata: integer; b1, b2, b3, b4, b5: byte); procedure batdataout(d: byte); begin wait4batready; bat8041datareg := chr(d); end; begin if batterypresent then begin wait4batready; bat8041cmdreg := chr(cmd); if numdata AD_1(CMD:BYTE; VAR DATA:BYTE); FUNCTION INITA804X:BOOLEAN; IMPLEMENT CONST UP = TRUE; DOWN = FALSE; TYPE STATUSTYPE = PACKED RECORD CASE INTEGER OF 0:(PAD1 :0..63; BUSY :BOOLEAN; >= 1 then batdataout(b1); if numdata >= 2 then batdataout(b2); if numdata >= 3 then batdataout(b3); if numdata >= 4 then batdataout(b4); if numdata >= 5 then batdataout(b5); end; end; procedure batreadbyte(var data: byte); begin wait4b READY :BOOLEAN); 1:(STATBYTE :CHAR); END; STRING3 = STRING[3]; VAR DATAREG [HEX('428001')] : CHAR; STATUSREG [HEX('428003')] : CHAR; CMDREG [HEX('428003')] : CHAR; ISRREC : ISRIB; MAXDATA atreadready; data := ord(bat8041datareg); end; procedure batinit; begin batcommand(167,2,23,112,0,0,0); {set power fail to 60 seconds} batcmdhook := dobatcommand; batreadhook:= batreadbyte; end; end; import bat, loader, sysdevs; begin if batter : SHORTINT; HAVEDATA : SHORTINT; DATABUFFER : WINDOWP; EXTLEFT,EXTRIGHT: BOOLEAN; MASK : BYTE; BOBBATPRESENT : BOOLEAN; {SFB 4/11/85} PROCEDURE DUMMYSTATUS56(VAR STATBYTE,DATABYTE:BYTE; VAR DONE:BOOLEAN); BEGIN END;ypresent THEN begin batinit; markuser; end; end.  PROCEDURE STATUS5ISR(VAR STATBYTE,DATABYTE:BYTE; VAR DONE:BOOLEAN); BEGIN { IF ANYTHING WRONG THEN RESET EXTENDCHAR BITS } { OTHERWISE IGNORE IT} IF DATABYTE>127 THEN BEGIN EXTLEFT:=FALSE; EXTRIGHT:=FALSE; END; END; PROCEDURE DATAISR     KBDSTATUS : STATUSTYPE; BEGIN REPEAT KBDSTATUS.STATBYTE:=STATUSREG; UNTIL NOT KBDSTATUS.BUSY; END; PROCEDURE SENDCMD(CMD:BYTE); BEGIN WAIT4KBDREADY; CMDREG:=CHR(CMD); END; PROCEDURE SENDDATA(DATA:BYTE); BEGIN WAIT4KBDREADY; DATAREG: SWISS_GR_KBD,NORWEGIAN_KBD,FRENCH_KBD,DANISH_KBD, KATAKANA_KBD,SPANISH_LATIN_KBD,US_KBD]; WHICHNONITFLANG = LANGNONITF[US_KBD,FRENCH_KBD,GERMAN_KBD,SWEDISH_KBD, SPANISH_KBD,KATAKAN=CHR(DATA); END; PROCEDURE CMD_READ_1(CMD:BYTE; VAR DATA:BYTE); BEGIN DATA := 0; {set ALL 16 BITS TO 0 - SFB 5/1/85} SETUPREAD(1,DATA,1); SENDCMD(CMD); WHILE HAVEDATA0 THEN BEGIN { POLL FOR INTERUPT OR JUST LEAVE } REPEAT KBDSTATUS.STATBYTE:=STATUSREG; UNTIL KBDSTATUS.READY OR NOT WAIT; IF KBDSTATUS.READY THEN BEGIN ISRIB=LANGITF[NO_KBD,NO_KBD,NO_KBD,SWISS_FR_KBD,NO_KBD,NO_KBD, NO_KBD,CDN_ENG_KBD,NO_KBD,NO_KBD,NO_KBD,ITALIAN_KBD, NO_KBD,DUTCH_KBD,SWEDISH_KBD,GERMAN_KBD, NO_KBD,NO_KBD, PTR := ADDR(ISRREC); A804XISR(ISRIBPTR); END; END; END; PROCEDURE SETUPREAD(COUNT:SHORTINT; ANYVAR BUFFER:WINDOW; OFFSET:SHORTINT); BEGIN MAXDATA:=COUNT; HAVEDATA:=0; DATABUFFER:=ADDR(BUFFER,OFFSET); END; PROCEDURE WAIT4KBDREADY; VAR  SWISS_FR_B_KBD, {CHANGED FOR 3.1--SFB--5/21/85} SPANISH_EUR_KBD, SWISS_GR_B_KBD, {CHANGED FOR 3.1--SFB--5/21/85} BELGIAN_KBD,FINISH_KBD,UK_KBD,CDN_FR_KBD,      ; { SET REPEAT RATE } SENDCMD(C); SENDDATA(256-DATA); END; 4,5: BEGIN IF CMD=4 THEN C:=HEX('20') {GET DELAY} ELSE C:=HEX('22'); {GET REPEAT} SENDCMD(C); { COPY DATA TO TIMER - SFB 3/2 intlevel; setintlevel(2); tmp := 0; sendcmd(hex('E0')); {address 8042 buffer} senddata(data*16 + reg); {packed as nibbles} sendcmd(hex('C2')); {trigger write} cmd_read_1(hex('C3'), tmp); 0/84 } CMD_READ_1(HEX('17'),DATA); DATA:=256-DATA; { READ byte from TIMER SFB 3/20/84 } END; 6: BEGIN { SET_KBDTYPE } CMD_READ_1(HEX('11'),KBDCONFIG); IF ODD(KB {read back for confirmation} write_bobbat := tmp; setintlevel(oldlevel); end; function read_bobbat(reg : integer) : integer; var tmp : byte; oldmask : byte; oldlevel : integer; begin oldlevel := intlevel; setintlevel(2); tmDCONFIG DIV 32) THEN BEGIN HIL_PRESENT:=TRUE; IF ODD(KBDCONFIG DIV 2) THEN KBDTYPE:=LARGEKBD ELSE KBDTYPE:=ITFKBD END ELSE BEGIN HIL_PRESENT:=FALSE; IF ODD(Kp := 0; sendcmd(hex('E0')); {address 8042 buffer} senddata(reg); cmd_read_1(hex('C3'), tmp); {trigger read and read} read_bobbat := tmp; setintlevel(oldlevel); end; procedure readbobtimedate(var yr, mm, dd, hr, mBDCONFIG) THEN KBDTYPE:=SMALLKBD ELSE KBDTYPE:=LARGEKBD; END; DATA:=KBDCONFIG; END; 7:BEGIN { SET_KBDLANG } CMD_READ_1(HEX('12'),DATA); CASE KBDTYPE OF SMALLKBD,LARGin, sec : integer); var i : integer; readok : boolean; buf : array[0..12] of shortint; begin repeat readok := true; for i := 0 to 12 do {read the bobbat time} buf[i] := read_bobbat(i); for i := 0 to 12 do EKBD : KBDLANG:=WHICHNONITFLANG[DATA]; ITFKBD : KBDLANG:=WHICHITFLANG[DATA MOD 32]; OTHERWISE KBDLANG:=NO_KBD; END; END; OTHERWISE END; END; PROCEDURE SEND_WAIT(L:STRING3); VAR I,J :  {and read again to ensure not rippling} if buf[i] <> read_bobbat(i) then readok := false; {at least 1 byte changed so it was rippling} until readok; sec := buf[1]*10 + buf[0]; min := buf[3]*10 + buf[2]; hr := (buf[5] modSHORTINT; { SEND COMMANDS & WAIT FOR DATA } BEGIN FOR I:=1 TO STRLEN(L) DO BEGIN J:=HAVEDATA; SENDCMD(ORD(L[I])); WHILE J=HAVEDATA DO; END; END; {Bobcat battery backed clock support--SFB 4/11/85} function bobcatbatterybackedclock : bool 4)*10 + buf[4]; dd := buf[8]*10 + buf[7]; mm := buf[10]*10 + buf[9]; yr := buf[12]*10 + buf[11]; {RDQ 14MAR88 yr 0..27 cvt to 100..127 yr 28..69 illegal yr 70..127 are ok} {patch for case where clock hardware rean; var tmp : byte; oldlevel : integer; begin oldlevel := intlevel; setintlevel(2); tmp := 0; bobcatbatterybackedclock := false; cmd_read_1(hex('11'), tmp); if odd(tmp div 32) then begin cmd_read_1(hex('FE'),tmp); {reolled the year over} if (yr>=0) and (yr<=27) then yr := yr +100; {invalid date screening} if (sec > 59) or (min > 59) or (hr > 23) or (dd > 31) or (mm > 12) or (yr > 127) or (yr < 70) or (dd = 0) or (mm = 0) then {LAF 880211 default time chanad extended ID reg on 8042} bobcatbatterybackedclock := odd(tmp div 32); end; setintlevel(oldlevel); end; function write_bobbat(data, reg : integer) : integer; var tmp : byte; oldmask : byte; oldlevel : integer; begin oldlevel :=ged to 1Jan70 from 1Mar00} begin {no valid timedate in bobbat clock} sec := 0; {so return default} min := 0; hr := 0; dd := 1; mm := 1; yr :=70; end; end; procedure setbobtimedate(yr, mm, dd, hr, min, sec :      TIME : RTCTIME; LTIME : TIMEREC; LDATE : DATEREC; SECS: INTEGER; BEGIN CASE CMD OF CGET: BEGIN { READ THE TIME AND DATE } THETIME.PACKEDTIME:=0; SETUPREAD(3,THETIME.PACKEDTIME,1); SENDCMD(HEX('3 range is now 0..127} MONTH:=MM; DAY:=DD; HOUR:=HR; MINUTE:=MIN; CENTISECOND:=SEC*100; PACKEDTIME:=TIMEDATE_TO_SECS(LDATE,LTIME); PACKEDTIME:=TTIME.PAC1')); SEND_WAIT(#21#20#19); THETIME.PACKEDDATE:=0; SETUPREAD(2,THETIME.PACKEDDATE,2); SEND_WAIT(#23#22); END; CSET: BEGIN { SET THE TIME AND DATE } SENDCMD(HEX('AD')); SENDBYTESLSF(3,THETIME.KEDTIME-TIMEZONE; {NOTE SUBTRACTION!} PACKEDDATE:=PACKEDTIME DIV 86400; PACKEDTIME:=(PACKEDTIME MOD 86400)*100; {UPDATE THE 8042} SENDCMD(HEX('AD')); SENDBYTESLSF(3,TTIME.PACKEDTIME,1); integer); var i : integer; tmp : byte; error : boolean; buf : array[0..12] of shortint; begin buf[0] := sec mod 10; {format the data for bobcat battery clock} buf[1] := sec div 10; buf[2] := min mod 10; buf[3] PACKEDTIME,1); SENDCMD(HEX('AF')); SENDBYTESLSF(2,THETIME.PACKEDDATE,2); IF BOBBATPRESENT THEN { UPDATE IT ALSO--SFB 4/11/85 } BEGIN TTIME.PACKEDTIME:=THETIME.PACKEDDATE*86400 := min div 10; buf[4] := hr mod 10; buf[5] := (hr div 10) + 8; {set "24-hour clock" bit} buf[6] := 0; {buf[6] is "don't care"} buf[7] := dd mod 10; buf[8] := dd div 10; buf[9] := mm mod 10; buf[10]:= mm div 10; bu +(THETIME.PACKEDTIME+50) DIV 100; TTIME.PACKEDTIME:=TTIME.PACKEDTIME+TIMEZONE; SECS_TO_TIMEDATE(TTIME.PACKEDTIME, LDATE, LTIME); WITH LTIME,LDATE DO {ADDED 4/17/86 JWS -- TIMEZONE FIX} {LAF 8f[11]:= yr mod 10; buf[12]:= yr div 10; repeat {try to send all 13 bytes of data} error := false; tmp := write_bobbat(15,13); {reset prescaler} for i := 0 to 12 do begin tmp := write_bobbat(buf[i], 80211 year range is now 0..127} SETBOBTIMEDATE(YEAR {MOD 100}, MONTH, DAY, HOUR, MINUTE, CENTISECOND DIV 100); END; {IF } END; CUPDATE: { SFB 4/11/85 } {UPDATE RTC FROM BOBi); {tmp is readback of data sent} if tmp <> buf[i] then error := true; end; until not error; {keep trying if error in transmission} end; function cvt_bob_to_rtc(yr,mm,dd,hr,min,sec : integer): rtctime; var ttime : rtctime; BAT, AND COPY TO THETIME AS SIDE EFFECT} BEGIN { COPY BOBCAT BATTERY BACKED CLOCK TO 8042 RTC } IF BOBBATPRESENT THEN { COPY IT TO RTC } BEGIN READBOBTIME ldate: daterec; ltime: timerec; begin with ldate, ltime do begin year:=yr {mod 100}; {LAF 880211 range is now 0..127} month:=mm; day:=dd; hour:=hr; minute:=min; centisecond:=sec*100; end; ttime.packedtime:=timedate_to_secs(ldatDATE(YR, MM, DD, HR, MIN, SEC); TTIME := CVT_BOB_TO_RTC(YR, MM, DD, HR, MIN, SEC); THETIME := TTIME; CLOCKOPS(CSET, TTIME); END; END; CTZ: {JWS 4/17/86 -- SET TIME ZONE, ADJUSe,ltime); ttime.packeddate:=ttime.packedtime div 86400; ttime.packedtime:=(ttime.packedtime mod 86400)*100; cvt_bob_to_rtc := ttime; end; PROCEDURE CLOCKOPS(CMD:CLOCKOP; VAR THETIME:RTCTIME); {MODS SFB 4/11/85} var yr,mm,dd,hr,min,sec : integer; TT LOCAL TIME} BEGIN IF BOBBATPRESENT THEN BEGIN {SET LOCAL TIME TO BATTERY + TZ } WITH LDATE, LTIME, TTIME DO BEGIN READBOBTIMEDATE(YR, MM, DD, HR, MIN, SEC); YEAR:=YR {MOD 100}; {LAF 880211      SENDCMD(HEX('AF')); SENDBYTESLSF(2,TTIME.PACKEDDATE,2); END; {WITH} END; { IF BOBBATPRESENT } END; {BEGIN} END; {CASE} END; PROCEDURE TIMEROPS(TIMER:TIMERTYPES; OP:TIMEROPTYPE; VAR SENDCMD(HEX('38')); SEND_WAIT(#21#20#19); TD.MATCH.HOUR:=TDATA DIV 360000; {TD.MATCH.MINUTE BUGFIX SFB 5/1/85} TD.MATCH.MINUTE:=(TDATA-(TD.MATCH.HOUR*360000)) DIV 6000;  TD:TIMERDATA); VAR TDATA:INTEGER; C : BYTE; BEGIN CASE OP OF SETT: CASE TIMER OF DELAYT,CYCLICT: BEGIN IF TIMER=CYCLICT THEN C:=HEX('BA') ELSE C:=HEX('B7'); SENDCMD(C); I TD.MATCH.CENTISECOND:= TDATA MOD 6000; END; OTHERWISE END; { CASE TIMER } END; GETTINFO: BEGIN TD.RESOLUTION:=10000; IF TIMER=DELAY7T THEN TD.RANGE:=65535 ELSE IF TIF TD.COUNT=0 THEN SENDCMD(HEX('31')) { TO CANCEL } ELSE BEGIN TDATA:=16777216-TD.COUNT; SENDBYTESLSF(3,TDATA,1); END; END; PERIODICT:; { DON'T DO ANY THING } DELAY7T: BEGIN SENMER=PERIODICT THEN TD.RANGE:=1 ELSE TD.RANGE:=16777215; END; END; { CASE OP } END; PROCEDURE KEYTRANS(VAR STATBYTE,KEY: BYTE; VAR DOKEY: BOOLEAN); VAR EXTSTATE: BOOLEAN; PROCEDURE SSET(VAR K:BOOLEAN); BDCMD(HEX('B2')); IF TD.COUNT=0 THEN SENDCMD(HEX('31')) { TO CANCEL } ELSE BEGIN TDATA:=65536-TD.COUNT; SENDBYTESLSF(2,TDATA,2); END; END; MATCHT: BEGIN EGIN K:=TRUE; DOKEY:=TRANSMODE=KPASS_EXTC; EXTSTATE:= DOKEY; END; PROCEDURE SCLEAR(VAR K:BOOLEAN); BEGIN K:=FALSE; DOKEY:=FALSE; IF TRANSMODE=KPASS_EXTC THEN EXTSTATE:= TRUE ELSE EXTSTATE:= NOT (EXTLEFT OR EXTRIGHT TDATA:=(TD.MATCH.HOUR*360000)+(TD.MATCH.MINUTE*6000)+ TD.MATCH.CENTISECOND; SENDCMD(HEX('B4')); IF TDATA=0 THEN SENDCMD(HEX('31')) { TO CANCEL } ); END; BEGIN {KEYTRANS} STATBYTE := (STATBYTE DIV 16)*16; DOKEY:=TRUE; IF KBDTYPE=ITFKBD THEN BEGIN IF TRANSMODE=KPASSTHRU THEN EXTSTATE:= UP ELSE BEGIN { NOT PASSTHRU } IF KEY=18 THEN SSET(EXTLEFT)  ELSE SENDBYTESLSF(3,TDATA,1); END; OTHERWISE END; { CASE TIMER } READT: BEGIN TDATA:=0; CASE TIMER OF DELAYT,CYCLICT: BEGIN SETUPREAD(3,TDATA,1); ELSE IF KEY=19 THEN SSET(EXTRIGHT) ELSE IF KEY=146 THEN SCLEAR(EXTLEFT) ELSE IF KEY=147 THEN SCLEAR(EXTRIGHT) ELSE BEGIN IF KBDSYSMODE THEN CASE KEY OF  IF TIMER=CYCLICT THEN C:=HEX('3E') ELSE C:=HEX('3B'); SENDCMD(C); SEND_WAIT(#21#20#19); TD.COUNT:=16777216-TDATA; END; PERIODICT: TD.COUNT:=1; DELAY7T: B 27: KEY:=26; {F1=K0} 28: KEY:=42; {F2=RECALL} 29: KEY:=51; {F5=STEP} 30: KEY:=49; {F6=ALPHA} 31: KEY:=50; {F7=GRAPHICS} 32: KEY:=45; {F3=CLR->END} 33: KEY:=58; {F4=EGIN SETUPREAD(2,TDATA,2); SENDCMD(HEX('36')); SEND_WAIT(#20#19); TD.COUNT:= 65536-TDATA; END; MATCHT: BEGIN SETUPREAD(3,TDATA,1); CONTINUE} 34,35: ; { UP AND DOWN ARROW KEYS } 36: KEY:=37; {F8=K9} OTHERWISE END; { CASE KEY } IF TRANSMODE=KSHIFT_EXTC THEN EXTSTATE:= NOT(EXTLEFT OR EXTRIGHT)      TE:=0; {JWS 3/31/87} SENDCMD(HEX('AD')); SENDBYTESLSF(3,THETIME.PACKEDTIME,1); {JWS 3/31/87} SENDCMD(HEX('AF')); SENDBYTESLSF(2,THETIME.PACKEDDATE,2); {JWS 3/31/87} INITA804X := TRUE; RECOVER IF ESCAPECODE<>-12 THEN ESCAPEyr,dd,mm,k,k1,k2: integer; ltime: rtctime; type day_month = array[0..12] of integer; const day_tab = day_month[0, 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31]; var days: integer; daysinmonth: integer; daysinyear: integer; done: b(ESCAPECODE); END; {INITA804X} END; {MODULE} IMPORT A804XDVR,LOADER; BEGIN IF INITA804X THEN MARKUSER; END. {PROGRAM} oolean; begin CALL(CLOCKIOHOOK,CGET,LTIME); with thedate do begin days:= ltime.packeddate; {Generate the year from date number} {RDQ 14MAR88 recoded to use isleap function and to correct 1 JAN two years after leap year bug}  ELSE EXTSTATE:= UP; END; END; { NOT PASSTHRU MODE } STATBYTE:=STATBYTE+(ORD(EXTSTATE)*8)+7; { INCLUDE EXTCHAR STATUS } END { ITFKBD } ELSE STATBYTE:=STATBYTE+15; { TURN ON ALL LOW ORDER BITS } END; {KEYTRANS} (* (c) Copyright Hewlett-Packard Company, 1986. All rights are reserved. Copying or other reproduction of this program except for archival purposes is prohibited without the prior written consent of Hewlett FUNCTION INITA804X:BOOLEAN; VAR i : integer; TEMP : BYTE; THETIME:RTCTIME; {JWS 3/31/87} BEGIN INITA804X:=FALSE; TRY TEMP := ORD(STATUSREG); { IS THE 8041/8042 PRESENT ? } MASK := 0; { INITIALIZE MASK } -Packard Company. RESTRICTED RIGHTS LEGEND Use, duplication, or disclosure by the Government is subject to restrictions as set forth in paragraph (b) (3) (B) of the Rights in Technical Data and Computer Software clause in DAR 7-104.9(a). HE MASKOPS(0,KBDMASK+RESETMASK+TIMERMASK+PSIMASK+FHIMASK); PERMISRLINK(A804XISR,ADDR(STATUSREG),1,1,1,ADDR(ISRREC)); HAVEDATA := 0; MAXDATA := 0; BFREQUENCY:=8; BDURATION:=8; BEEPERHOOK := BEEPOP; RPGREQHOOK := DO_RPGOPS; WLETT-PACKARD COMPANY Fort Collins, Colorado *) $modcal$ $heap_dispose off$ $iocheck off$ $range off$ $ovflcheck off$ $debug off$ $stackcheck off$ { $search 'INITLOAD','ASM','INIT','SYSDEVS'$ } program clockinit(OUTPUT); module KBDREQHOOK := DO_KBDOPS; KBDPOLLHOOK:= POLLISR; CLOCKIOHOOK:= CLOCKOPS; TIMERIOHOOK:= TIMEROPS; DATAHOOK := DATAISR; DO_KBDOPS(SET_KBDTYPE,TEMP); DO_KBDOPS(SET_KBDLANG,TEMP); KBDSYSMODE :=TRUE; IF KBD clock; import sysglobals, asm, misc, sysdevs; export procedure initclock; implement const {LAF 870310} date_base_offset = { days between 1-Mar-00 and 1-Jan-70 } (365*4+1)*17 { add 68 years: we're at 1-Mar-68 } +365*2 TYPE=ITFKBD THEN SETSTATUS(6,'S'); TRANSMODE := KPASSTHRU; KBDALTLOCK := FALSE; KBDCAPSLOCK:=TRUE; EXTLEFT := FALSE; EXTRIGHT := FALSE; KBDTRANSHOOK:= KEYTRANS; MASKOPSHOOK := MASKOPS; STATUS5HOOK := DUMMYSTATUS56 { add 2 more years: we're at 1-Mar-70 } -31-28; { subtract January and February 1970: we're at 1-Jan-70 } type trickint = packed record case integer of 0: ( ; STATUS6HOOK := DUMMYSTATUS56; BOBBATPRESENT := BOBCATBATTERYBACKEDCLOCK; {SFB 4/11/85} {FIX TO CLEAR 804X CLOCK IN CASE OTHER OS SET IT TO A STRANGE BASE } THETIME.PACKEDTIME:=0; {JWS 3/31/87} THETIME.PACKEDDAipart: integer ); 1: ( byte3: byte; byte2: byte; byte1: byte; byte0: byte ) end; var boottype[-576]: shortint; procedure dosysdate(var thedate: daterec); var      year:=70; daysinyear := 365 + isleap(year); while days>=daysinyear do begin days:=days-daysinyear; year:=year+1; daysinyear := 365 + isleap(year); end; {LAF 880101 proper range is now 0..127} {year:=year mod 100; hen begin for i:=70 to (year-1) do begin packeddate:= packeddate + 365 + isleap(i); end; for i:=1 to (month-1) do begin packeddate:= packeddate + day_tab[isleap(year)][i]; end; packeddate:= packedd{get it into proper range} {Generate month from remaining days} {RDQ 14MAR88 recoded to use isleap function} month:=0; done:=false; repeat daysinmonth:=day_tab[month]; if (month=2) then daysinmonth:=daysinmonth + isleap(yeaate + day-1; end; end; {with} setrtctime(ltime); end; procedure dosetsystime(thetime: timerec); var ltime: rtctime; hr,min,ctsec: integer; begin CALL(CLOCKIOHOOK,CGET,LTIME); with ltime, thetime do begin hr := hour; min := minuter); if days>=daysinmonth then begin days:=days-daysinmonth; month:=month+1 end else done:=true; until done; {days is now offset into month} day:=days+1; end; {of with} end; procedure dosystime(var the; ctsec := centisecond; packedtime:=((hr*3600)+min*60)*100+ctsec; end; setrtctime(ltime); end; {added for 3.2} procedure dosetzone(thezone: timerec); var ltime: rtctime; negative: boolean; {kludge for negative tz} begin if (thezone.centtime: timerec); var t: integer; begin t:=sysclock mod (24*360000); with thetime do begin hour := t div 360000; minute := (t-(hour*360000)) div 6000; centisecond := t mod 6000; end; end; procedure setrtctime(thetime: rtctime);isecond mod 100)<>0 then begin negative:=true; thezone.centisecond:=(thezone.centisecond div 100)*100; end else negative:=false; ltime.packedtime:=thezone.hour*3600 + thezone.minute*60 +thezone.centisecond div 100; i const cmmdb7=183; cmmd40=64; var t1,t2: trickint; TTIME: RTCTIME; begin TTIME:=THETIME; CALL(CLOCKIOHOOK,CSET,TTIME); {LAF 870310 3.2G The following adjustment converts the time from 1-Jan-70 base in the 8042 RTC to 1-Mar-00 baf negative then ltime.packedtime:=-ltime.packedtime; timezone:=ltime.packedtime; call(clockiohook, ctz, ltime); call(clockiohook, cget, ltime); setrtctime(ltime); {because local time may have changed} end; procedure inittime; var thetime:rtctime; se in the battery backed clock} t1.ipart := thetime.packeddate+date_base_offset; t2.ipart := thetime.packedtime; batcommand(cmmdb7,5,t1.byte1,t1.byte0,t2.byte2,t2.byte1,t2.byte0); batcommand(cmmd40,0,0,0,0,0,0); end; { setrtctime } procedure doconst cmmd41=65; {65 hex to load timer output buffer with time} cmmdf7=247; {F7 hex to load data buffer with first byte} cmmdf6=246; {F6 hex to load data buffer with second byte} cmmdf5=245; setsysdate(thedate: daterec); type day_month = array [0..12] of integer; table = array[0..1] of day_month; const day_tab = table[ day_month[0, 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31], day_month[0, 31, 29, 31, 30, 31, 30, 31,  {F5 hex to load data buffer with third byte} cmmdf4=244; {F4 hex to load data buffer with fourth byte} cmmdf3=243; {F3 hex to load data buffer with fifth byte} cmmdf2=242; {F2 he31, 30, 31, 30, 31]]; var ltime: rtctime; i : integer; {RDQ 14MAR88 import isleap from SYSDEVS } begin CALL(CLOCKIOHOOK,CGET,LTIME); ltime.packeddate:=0; {default value} with ltime, thedate do begin if ( month <> 0 ) and ( year >= 70 ) tx to load a letter 'B',or'P', or'H' for Basic, or Pascal, or HPL respectively} var t: trickint; begin {inittime} thetime.packedtime := 0; thetime.packeddate := 0; if batterypresent then with t do begin      RIGHTS LEGEND Use, duplication, or disclosure by the Government is subject to restrictions as set forth in paragraph (b) (3) (B) of the Rights in Technical Data and Computer Software clause in DAR 7-104.9(a). HEWLETT-PACKARD COMPANY Fort Collins, Colora '!"$%&/()=?^;:_'], {dutch} t1['1234567890/|<:,.-', '!"#$%&_()''?\^>+;*='], {swiss gr} t1['1234567890!ϫ,.-', '+"*%&/()=?ɨ;:_'], {swiss fr} t1['1234567890!ɫ,.-', 'do *) $SYSPROG$ $heap_dispose off$ $iocheck off$ $range off$ $ovflcheck off$ $debug off$ $stackcheck off$ program NON_US_KBD2INIT; import sysdevs,misc; const lowtable = ord(finish_kbd); {SFB--5/22/85} hitable = ord(+"*%&/()=?Ϩ;:_'], {spanish_eur} t1['1234567890''`@+,.-', '!"$%&/()=?#*;:_'], {spanish_lat} t1['1234567890-='';,./', '!@#$%^&*()_+":<>?'], {uk} t1['1234567890+''[]*\,.-', '!"$%&^ setintlevel(2); ipart := 0; batcommand(cmmd41,0,0,0,0,0,0); batcommand(cmmdf7,0,0,0,0,0,0); byte1 := batbytereceived; batcommand(cmmdf6,0,0,0,0,0,0); byte0 := batbytereceived; {LAF 870310 3.2G The following adjustment convswedish_kbd)+2; {SFB--5/22/85} type t1 = packed array[boolean, 80..98] of char; t2 = packed array[lowtable..hitable] of t1; {SFB--5/22/85} t3 = packed array[boolean, 1..2] of char; t4 = packed array[lowtable..hitable] of t3; {SFB--5/22/85} conerts the time from 1-Mar-00 base in the battery backed clock to 1-Jan-70 base in the 8042 RTC} thetime.packeddate := ipart-date_base_offset; ipart := 0; batcommand(cmmdf5,0,0,0,0,0,0); byte2 := batbytereceived; batcommandst lowkeys = t4[ {finish} t3['<''','>*'], {belgian} t3['$<','>'], {canadian eng} t3[']@','[#'], {canadian fr } t3[']@','[#'], {norwegian} t3['<@','>*'], {danish} t3['<@','>*(cmmdf4,0,0,0,0,0,0); byte1 := batbytereceived; batcommand(cmmdf3,0,0,0,0,0,0); byte0 := batbytereceived; thetime.packedtime := ipart; setintlevel(0);{lower cpu int level} end else call(clockiohook, cupdate, thetime); {SFB'], {dutch} t3['@',''#190{f}], {swiss gr} t3['$',''], {swiss fr} t3['$',''], {spanish_eur} t3['<','>'], {spanish_lat} t3['`',''], {uk} t3['`<','~>'],  4/11/85} setrtctime(thetime); end; { inittime } PROCEDURE DOCLOCKOPS(CMD:CLOCKFUNC; ANYVAR DATA: CLOCKDATA); BEGIN CASE CMD OF CGETDATE: DOSYSDATE(DATA.DATETYPE); CGETTIME: DOSYSTIME(DATA.TIMETYPE); CSETDATE: DOSETSYSDATE(DATA.DATETYPE);  {italian} t3['<*','>'], {french} t3['$<','>'], {german} t3['<','>^'], {swedish} t3['<''','>*'], {swiss gr B} t3['$',''], {SFB--5/21/85} {swiss fr B} t3['$',''] {SFBCSETTIME: DOSETSYSTIME(DATA.TIMETYPE); CSETZONE: DOSETZONE(DATA.TIMETYPE); END; END; procedure initclock; begin inittime; CLOCKREQHOOK:=DOCLOCKOPS; end; end; { module clock } import clock, loader; begin initclock; markuser; end. --5/21/85} ]; specials =t2[ {finish} t1['1234567890+,.-', '!"#$%&/()=?;:_'], {belgian} t1['&"''(!)-`m;:=', '1234567890_*M%./+'], {canadian eng} t1['1234567890-=;,.',  (* (c) Copyright Hewlett-Packard Company, 1984. All rights are reserved. Copying or other reproduction of this program except for archival purposes is prohibited without the prior written consent of Hewlett-Packard Company. RESTRICTED '!"/$%?&*()_+'#180':''<>'], {canadian fr } t1['1234567890-=;,.', '!"/$%?&*()_+'#180':''<>'], {norwegian} t1['1234567890+ԫ,.-', '!"#$%&/()=?^;:_'], {danish} t1['1234567890+ԫ,.-',     ()=?/{}@|;:_'], {italian} t1['"''(_ɪ)-$m;:', '1234567890+=&M%./!'], {french} t1['&"''(!)-`m;:=', '1234567890_*M%./+'], {german} t1['1234567890''+,.-', '!"$%&/()=?`*belgian_kbd: begin keytable[119].no_capslock:=true; keytable[94].no_capslock:=false; { exchange z-w and Mm<-,? } keytable[119].keys[false]:=','; keytable[119].keys[true]:='?'; keytable[105]:=keytable[120]; { z<-w } keytable;:_'], {swedish} t1['1234567890+,.-', '!"#$%&/()=?;:_'], {swiss gr B} t1['1234567890!ϫ,.-', {SFB--5/21/85} '+"*%&/()=?ɨ;:_'], {swiss fr B} t1['1234567890!ɫ,.-', {SFB-[120].keys[false]:='w'; keytable[120].keys[true]:='W'; if kbdlang<>italian_kbd then begin { exchange a-q } keytable[104]:=keytable[112]; { q<-a } keytable[112].keys[false]:='q'; keytable[112].keys[true]:='Q'; end ELSE -5/21/85} '+"*%&/()=?Ϩ;:_'] ]; procedure doinit; var i : -32768..32767; lang_for_table : integer; begin if (kbdtype=ITFkbd) and ( ((kbdlang>=finish_kbd) and (kbdlang<=swedish_kbd)) or (kbdlang>=swiss_gr_B_kbd) ) {adde KEYTABLE[87].KEYCLASS:=NONA_ALPHA_KEY; { 5/9/84 SFB } end; cdn_eng_kbd,cdn_fr_kbd: begin keytable[93].no_capslock:=false; keytable[98].no_capslock:=false; KEYTABLE[95].KEYCLASS:=NONA_ALPHA_KEY; { 5/9/84 SFB } end; nod 3.1 for new keyboards-SFB--5/22/85} and (langtable[0]<>nil) then if (langtable[0]^.langcode=us_kbd) then begin with langtable[0]^ do begin { extend char keys are extenstion bit } if kbdlang > swedish_kbd then lang_frwegian_kbd,german_kbd,danish_kbd: { REMOVED SWEDISH 5/10/84 SFB } begin keytable[92].no_capslock:=false; keytable[94].no_capslock:=false; keytable[95].no_capslock:=false; if kbdlang=german_kbd then begin { switch z-y } or_table := ord(kbdlang)-ord(swiss_gr_B_kbd)+ord(swedish_kbd)+1 {offset into specials and lowkeys for kbdlang > swedish_kbd. Use lang_for_table for all accesses into these tables, but not elsewhere. Yecch !!!} else lang_for_table := ord(k keytable[120]:=keytable[109]; { y<-z } keytable[109].keys[false]:='z'; keytable[109].keys[true]:='Z'; end; end; swiss_gr_kbd,swiss_fr_kbd,swiss_gr_B_kbd,swiss_fr_B_kbd: {SFB--5/21/85} begin { switch z-y } keytable[120]:=keytable[1bdlang); transmode:=kshift_extc; langcode :=kbdlang; { load special alpha keys } keytable[1].keys[false]:=lowkeys[lang_for_table,false,1]; keytable[1].keys[true]:=lowkeys[lang_for_table,true,1]; keytable[2].keys[false]:09]; { y<-z } keytable[109].keys[false]:='z'; keytable[109].keys[true]:='Z'; KEYTABLE[93].KEYCLASS:=NONADV_KEY; if (KBDLANG = swiss_gr_B_kbd) or (KBDLANG = swiss_fr_B_kbd) then begin {added for new keyboards 46020BQ,46020BP SFB--5=lowkeys[lang_for_table,false,2]; keytable[2].keys[true]:=lowkeys[lang_for_table,true,2]; for i:=80 to 98 do with keytable[i] do begin keys[false]:=specials[lang_for_table,false,i]; keys[true]:=specials[lang_for_table,true,i]; /21/85} keytable[93].keys[true] := '!'; keytable[90].keys[false]:= ''''; {apostrophe} KEYTABLE[93].KEYCLASS:=NONA_ALPHA_KEY; {SFB--5/21/85} end; end; uk_kbd,dutch_kbd:; { no changes } spanish_latin_kbd,spanish_eur_kbd end; case kbdlang of { language fixups } finish_kbd,SWEDISH_KBD: { ADDED SWEDISH 5/10/84 SFB } for i:=91 to 95 do keytable[i].no_capslock:=false; { CHANGED BOTTOM INDEX OF ABOVE LOOP TO 91 5/8/84 SFB } italian_kbd,french_kbd,: keytable[94].no_capslock:=false; spanish_kbd,katakana_kbd:; { not implemented here } otherwise end; langindex:=0; kbdcapslock:=true; kbdaltlock:=false; IF KBDLANG IN { THESE MODS 5/9/84 SFB } [NORW      *) $sysprog$ $stackcheck off$ $heap_dispose off$ $iocheck off$ $range off$ $ovflcheck off$ $debug off$ program absinit(OUTPUT);{SFB 3/13/85} {MODIFIED SFB 3/26/85, 4/4/85} module abs_locator; { DGL HPHIL abolute locator module } {$SEAen gdata.d[devstate]:=255 { sign extend } else gdata.d[devstate]:=0; gdata.d[devstate+1]:=databyte; end; devstate:=devstate+1+ord(not descrip.size16); if not descrip.size16 then begin { 8 bit mode } cindex:=cindex+1; if cindex>=gdata.RCH 'IOLIB:IOCOMASM'} import sysdevs,sysglobals,iocomasm,asm; export function initabs : boolean; implement type sint = -32768..32767; pollblock = packed record case integer of 0:(d: packed array[1..7] of byte); 1:(twosets : bonumaxes then devstate:=8; end; end; 3,5,7: { co-ord data } { high byte } begin if recording then gdata.d[devstate-1]:=databyte; devstate:=devstate+1; cindex:=cindex+1; if cindex>=gdata.numaxes then devstate:=8; end; 8:begEGIAN_KBD,DANISH_KBD,SWISS_GR_KBD,SWISS_FR_KBD, SWISS_GR_B_KBD, SWISS_FR_B_KBD] THEN {ADDED SFB--5/30/85} KEYTABLE[91].KEYCLASS:=NONADV_KEY; IF KBDLANG IN [NORWEGIAN_KBD,DANISH_KBD] THEN KEYTABLE[93].KEYCLASS:=NONA_ALPHA_KEY; IF KBolean; kcodes : 0..3; filler : boolean; {SFB 3/27/85} checkstat: boolean; {SFB 3/27/85} ready : boolean; {SFB 3/27/85} numaxes : 0..3; xdata : sint; ydata : sint; zdDLANG IN [DUTCH_KBD,SPANISH_EUR_KBD] THEN KEYTABLE[95].KEYCLASS:=NONADV_KEY; IF KBDLANG = DUTCH_KBD THEN { 3.01 BUG FIX 9/20/84 SFB } KEYTABLE[92].KEYCLASS:=NONA_ALPHA_KEY; IF KBDLANG = FRENCH_KBD THEN { 3.01 BUG FIX 9/20/84 SFB } ata : sint) end; const touchscreenid = hex('8c'); proximitykey = hex('8e') div 2; no_button = -1; var driver : loopdvrptr; dvr_comm_rec : hphil_comm_rec_ptr_type; abskey : sint; {button for present pKEYTABLE[92].KEYCLASS:=NONADV_KEY; IF KBDLANG IN [BELGIAN_KBD,SPANISH_LATIN_KBD,CDN_ENG_KBD,CDN_FR_KBD] THEN KEYTABLE[92].KEYCLASS:=NONADV_KEY; { IF KBDLANG=SPANISH_EUR_KBD THEN KEYTABLE[91].KEYCLASS:=NONA_ALPHA_KEY; } {REMOVED SFollblock} gdata : pollblock; gid : sint; {loop address of owner of present pollblock} cindex : 0..3; recording, proximity, {current proximity state} pollprox, {proximB 6/14/85} end; { with langtable[0]^ } end; end; { doinit } begin doinit; { structure is to avoid global vars } end. ity state for present pollblock} dataready : boolean; procedure doreset; var i, thisdev : sint; begin for i:= 1 to 7 do gdata.d[i] := 0; abskey := no_button; gid := 0; dataready := false; proximity := true ;(* (c) Copyright Hewlett-Packard Company, 1985. All rights are reserved. Copying or other reproduction of this program except for archival purposes is prohibited without the prior written consent of Hewlett-Packard Company. RESTRICTED RIGHTS LEGE {WOULD LIKE TO ASK DEVICE, BUT CAN'T} end; procedure absdataproc(var statbyte,databyte:byte; var done:boolean); begin with loopcontrol^ do with loopdevices[loopdevice] do case devstate of 1:begin if recording then begin gdataND Use, duplication, or disclosure by the Government is subject to restrictions as set forth in paragraph (b) (3) (B) of the Rights in Technical Data and Computer Software clause in DAR 7-104.9(a). HEWLETT-PACKARD COMPANY Fort Collins, Colorado .d[1]:=databyte; gid := loopdevice; end; cindex:=0; if gdata.numaxes=0 then devstate:=8 else devstate:=2; end; 2,4,6: begin { co-ord data } { low byte } if recording then begin if not descrip.size16 then if databyte>127 th      in { keydata } case gdata.kcodes of 0:; { not supposed to be any data } 1:; { ignore ASCII for DGL } otherwise { key code data--either keyset accepted } if databyte div 2 <> proximitykey then if (abskey = no_button) gdata.numaxes > 1 then {update only if y in pollblock} yloc := gdata.ydata; if (hasbuttons) and (not upstroke) and (not (abskey = no_button)) then begin ncodes := 1; {only keep first key when latching for DGL}  and (recording) then abskey := databyte {pick up only first button pressed} else { do nothing } else {proximity transition encountered} begin if bit_set(dvr_comm_rec^.devices,gid-1) then begin proximi codes[1] := chr(abskey); end; end; end else {not pollprox so try to update for touchscreen} if (not hasbuttons) and loopcontrol^.loopdevices[gid].descrip.proximity then begin ncodes := 1; codes[1] := chr(hex('8f')); ty := not odd(databyte); {record proximity} if recording then pollprox := proximity; {and update for this pollblock} end; end; end; {case gdata.kcodes} end; {case 8} end; {case devstate} end; {abs {= "exit proximity" code} end; {ended back to if dataready} abskey := no_button; gid := 0; end; dataready := false; setintlevel(oldlevel); end; procedure absopsproc(op:loopdvrop); begin with loopcontrol^, dataproc} {do_update assumes it's handed correct comm_rec_ptr, NOT head of list. If pointer points at wrong record, do_update quits in disgust, clearing dataready, gid and abskey. Keep a copy of the correct pointer in calling procedure, after ldvr_comm_rec^ do with loopdevices[loopdevice] do case op of datastarting: begin devstate := 1; if not dataready then begin recording := active; pollprox := proximity; abskey := no_button; end else recording :=ocating it.} procedure do_update(a_comm_rec : hphil_comm_rec_ptr_type); var oldlevel : integer; hasbuttons:boolean; upstroke : boolean; begin oldlevel := intlevel; setintlevel(1); with a_comm_rec^ do if dataready then if g false; end; dataended: if recording or dataready then begin dataready := true; if not reading then do_update(dvr_comm_rec); end; resetdevice: doreset; otherwise begin end end; end; { absopsproc} function initabsid <> 0 then {can check if the gid'th device is to be handled} if (bit_set(devices,gid-1)) and (dvr_type = abslocator) then begin if extend = 1 then {see if application requested "set proximity"} proximity := true; if extend = -1 t : boolean; var i, thisdev : integer; begin if HIL_PRESENT {(kbdtype=itfkbd)} and (driver=nil) then begin new(driver); new(dvr_comm_rec); with driver^ do { initialize driver log in record } begin lowihen proximity := false; extend := 0; {and clear any "set proximity" request} hasbuttons := loopcontrol^.loopdevices[gid].descrip.nbuttons <> 0; dev_addr := gid; if pollprox then {only update for tablet if in proximity range} begin d :=hex('80'); { all absolute pointers } highid :=hex('9f'); daddr :=0; { any device address } opsproc :=absopsproc; { set procedure vars } dataproc:=absdataproc; next :=loopdriverlist; { add to dr upstroke := odd(abskey); if (ncodes = 0) or (not latch) then {can update if no buttons yet received, or not digitizing (not latching)} begin if gdata.numaxes > 0 then {update only if x in pollblock} xloc := gdata.xdata; ifiver list } loopdriverlist:=driver; end; with dvr_comm_rec^ do {frontlink dvr_comm_rec into sysdevs globals} begin link := hphil_data_link; hphil_data_link := dvr_comm_rec; update := do_update; devices := hex('7f');       GL HPHIL relative locator module } {$SEARCH 'IOLIB:IOCOMASM'} import sysdevs,sysglobals,iocomasm,asm; export function initrel : boolean; implement type sint = -32768..32767; sintptr = ^sint; pollblock = packed record case integer alt_dvr <> nil then call(alt_dvr^.opsproc, op); end; function inactive : boolean; {is locator_init not done, or is the device masked out by output_esc 1090?} var temp : boolean; begin gid := loopcontrol^.loopdevice; with dvr_comm_re of 0:(d: packed array[1..7] of byte); 1:(twosets : boolean; kcodes : 0..3; filler : boolean; {SFB 3/27/85} checkstat: boolean; {SFB 3/27/85} ready : boolean; {SFB 3/27/85} numaxes : c^ do begin if gid <> 0 then {can check if the gid'th device is to be handled} temp := (not bit_set(devices,gid-1)) or (dvr_type <> rellocator) else temp := true; inactive := temp or (not active); end; end; proc{this comm_rec handles ALL abs locators} dev_addr := 0; xloc := 0; yloc := 0; ncodes := 0; latch := false; active := false; dvr_type := abslocator; end; { with dvr_comm_rec^ do } if loopcontrol^.loopisok then c0..3; xdata : sint; ydata : sint; zdata : sint) end; const no_button = -1; var driver,alt_dvr : loopdvrptr; dvr_comm_rec : hphil_comm_rec_ptr_type; relkey : sint; {button for present poall(hphilcmdhook,configureop); {connect the ISRs} initabs:=true; end else initabs:=false; end; { initabs } end; { DGL HPHIL absolute locator interface module } import abs_locator, loader; begin if initabs then markuser;llblock} gdata : pollblock; gid : sint; {loop address of owner of present pollblock} cindex : 0..3; recording, dataready : boolean; procedure relopsproc(op:loopdvrop); forward; function samecode( end. d : loopdvrptr) : boolean; begin samecode := d^.opsproc = relopsproc; end; procedure doreset; var i, thisdev : sint; begin for i:= 1 to 7 do gdata.d[i] := 0; relkey := no_button; gid := 0; dataready := false; (* (c) Copyright Hewlett-Packard Company, 1985. All rights are reserved. Copying or other reproduction of this program except for archival purposes is prohibited without the prior written consent of Hewlett-Packard Company. RESTRICTED RIGHTS LEGEend; procedure find_altdriver; var temp : loopdvrptr; found : boolean; begin found := false; temp := loopdriverlist; while (temp <> nil) and (not found) do begin with loopcontrol^, loopdevices[loopdevice] do if (temp^ND Use, duplication, or disclosure by the Government is subject to restrictions as set forth in paragraph (b) (3) (B) of the Rights in Technical Data and Computer Software clause in DAR 7-104.9(a). HEWLETT-PACKARD COMPANY Fort Collins, Colorado .daddr = 0) or (temp^.daddr = loopdevice) then if (descrip.id >= temp^.lowid) and (descrip.id <= temp^.highid) then if not samecode(temp) then found := true; if not found then temp := temp^.next; end; alt_dvr := temp; end; p *) $modcal$ $stackcheck off$ $heap_dispose off$ $iocheck off$ $range off$ $ovflcheck off$ $debug off$ program relinit(output);{SFB 3/13/85} {MODIFIED SFB 3/26/85, 4/4/85} {Hacked for relative driver SFB 9/9/85} module rel_locator; { Drocedure alt_dataproc(var statbyte,databyte:byte; var done:boolean); begin find_altdriver; if alt_dvr <> nil then call(alt_dvr^.dataproc, statbyte, databyte, done); end; procedure alt_opsproc(op:loopdvrop); begin find_altdriver; if      edure reldataproc(var statbyte,databyte:byte; var done:boolean); begin with loopcontrol^ do with loopdevices[loopdevice] do if inactive then alt_dataproc(statbyte, databyte, done) else case devstate of 1:begin if recording thes,gid-1)) and (dvr_type = rellocator) then begin hasbuttons := loopcontrol^.loopdevices[gid].descrip.nbuttons <> 0; dev_addr := gid; upstroke := odd(relkey); if (ncodes = 0) or (not latch) then {can update if no buttons yet received, oen begin gdata.d[1]:=databyte; {gid := loopdevice;} end; cindex:=0; if gdata.numaxes=0 then devstate:=8 else devstate:=2; end; 2,4,6: begin { co-ord data } { low byte } if recording then begin if not descrip.size16 then r not digitizing (not latching)} {Fix follows for minor bug FSDdt02078, where revving mouse a large amount caused cursor to flip to opposite side of CRT. It was because xloc (below) is 16-bit, and would overflow silently (range is off), chan if databyte>127 then gdata.d[devstate]:=255 { sign extend } else gdata.d[devstate]:=0; gdata.d[devstate+1]:=databyte; end; devstate:=devstate+1+ord(not descrip.size16); if not descrip.size16 then begin { 8 bit mode } cindex:=cindex+1;ging sign. Fix below clips to proper edge of 16-bit space, depending on sign of gdata.xdata. Same discussion holds for yloc. SFB 12/22/88} with loopcontrol^.loopdevices[gid].descrip do {MOVED - SFB 12/22/88} begin if gdata.numaxes > 0 then if cindex>=gdata.numaxes then devstate:=8; end; end; 3,5,7: { co-ord data } { high byte } begin if recording then gdata.d[devstate-1]:=databyte; devstate:=devstate+1; cindex:=cindex+1; if cindex>=gdata.numaxes then devstate:=8; {update only if x in pollblock} TRY {SFB 12/22/88} $RANGE ON$ {SFB 12/22/88} xloc := xloc + gdata.xdata; $RANGE OFF$ {SFB 12/22/88} RECOVER  end; 8:begin { keydata } case gdata.kcodes of 0:; { not supposed to be any data } 1:; { ignore ASCII for DGL } otherwise { key code data--either keyset accepted } if (relkey = no_button) and (recording) then {SFB 12/22/88} IF ESCAPECODE <> -8 THEN {SFB 12/22/88} ESCAPE(ESCAPECODE) {SFB 12/22/88} ELSE {SFB 12/22/88} IF GDATA.XDATA>0 THEN {SFB 12/22/88} XLOC relkey := databyte {pick up only first button pressed} end; {case gdata.kcodes} end; {case 8} end; {case devstate} end; {reldataproc} {do_update assumes it's handed correct comm_rec_ptr, NOT head of list. If := maxcountx; {SFB 12/22/88} {ELSE {SFB 12/22/88 - NOT NEEDED AS ALWAYS CLIP TO 0 BELOW} {XLOC:= 0; {SFB 12/22/88} if gdata.numaxes > 1 then {update only if y in pollblock} TRY {SFB pointer points at wrong record, do_update quits in disgust, clearing dataready, gid and relkey. Keep a copy of the correct pointer in calling procedure, after locating it.} procedure do_update(a_comm_rec : hphil_comm_rec_ptr_type); var oldle 12/22/88} $RANGE ON$ {SFB 12/22/88} yloc := yloc + gdata.ydata; $RANGE OFF$ {SFB 12/22/88} RECOVER {SFB 12/22/88} IF ESCAPECODE <> -8 THEN {SFB 12/2vel : integer; hasbuttons:boolean; upstroke : boolean; begin oldlevel := intlevel; setintlevel(1); with a_comm_rec^ do if dataready then if gid <> 0 then {can check if the gid'th device is to be handled} if (bit_set(devic2/88} ESCAPE(ESCAPECODE) {SFB 12/22/88} ELSE {SFB 12/22/88} IF GDATA.YDATA>0 THEN {SFB 12/22/88} YLOC:= maxcounty; {SFB 12/22/88} {ELSE {SFB 12/22/88 - NOT       peat $PARTIAL_EVAL ON$ while (tdriver <> nil) and not samecode(tdriver^.next) do tdriver := tdriver^.next; {keep searching for this reldriver} $PARTIAL_EVAL OFF$ if tdriver <> nil then begin if tdriver^.next <> nil then { initrel:=false; end; { initrel } end; {rel_locator} import rel_locator, loader; begin if initrel then markuser; end. else something WRONG! so do nothing} begin {link rel to head of list} temp2 := tdriver^.next; tdriver^.next := tdriver^.next^.next; temp2^.next := loopdriverlist; loopdriverlist := temp2; end; end; un (* (c) Copyright Hewlett-Packard Company, 1985. All rights are reserved. Copying or other reproduction of this program except for archival purposes is prohibited without the prior written consent of Hewlett-Packard Company. RESTRICTEDNEEDED AS ALWAYS CLIP TO 0 BELOW} {YLOC:= 0; {END FIX.SFB 12/22/88} if xloc < 0 then xloc := 0; if yloc < 0 then yloc := 0; if xloc > maxcountx then xloc := maxcountx; if yloc > maxcounty then yloc := maxcounty; entil tdriver = nil; end; otherwise begin end; end; {case} if (inactive) or not ((op = datastarting) or (op = dataended)) then alt_opsproc(op); end; { relopsproc} function initrel : boolean; const ndrivers = 2; d; {with loopcontrol^.loopdevices[gid].descrip} if (hasbuttons) and (not upstroke) and (not (relkey = no_button)) then begin ncodes := 1; {only keep first key when latching for DGL} codes[1] := chr(relkey); end; relkey := no_butto type idarraytype = array[1..ndrivers] of SHORTINT; const lowids = idarraytype[96, 224]; highids = idarraytype[127, 224]; var i, thisdev : integer; begin if (HIL_PRESENT) and (driver=nil) then begin for i := 1 to ndrivn; gid := 0; end; dataready := false; setintlevel(oldlevel); end; procedure relopsproc(op:loopdvrop); var tdriver, temp2 : loopdvrptr; I : INTEGER; begin with loopcontrol^, loopdevices[loopdevice], dvr_comm_rec^ ders do begin new(driver); with driver^ do { initialize driver log in record } begin lowid :=lowids[i]; { all relative pointers } highid :=highids[i]; daddr :=0; { any device address } opso case op of datastarting: if not(inactive) then begin devstate := 1; if not dataready then begin recording := active; relkey := no_button; end else recording := false; end; dataended: if not(inproc :=relopsproc; { set procedure vars } dataproc:=reldataproc; next :=loopdriverlist; { add to driver list } loopdriverlist:=driver; end; end; new(dvr_comm_rec); with dvr_comm_rec^ do {frontlink dvr_active) and (recording or dataready) then begin dataready := true; if not reading then do_update(dvr_comm_rec); end; resetdevice: begin doreset; end; uninitdevice: begin xloc := 0; {set up REL drivecomm_rec into sysdevs globals} begin link := hphil_data_link; hphil_data_link := dvr_comm_rec; update := do_update; devices := hex('7f'); {this comm_rec handles ALL rel locators} dev_addr := 0; xloc := 0; yloc := 0; ncodes  TO "idle" SFB} yloc := 0; ncodes := 0; latch := false; active := false; {put all reldrivers at head of list SFB} tdriver := loopdriverlist; {if at this point samecode(tdriver), this one's at head of list anyway...} re := 0; latch := false; active := false; dvr_type := rellocator; end; { with dvr_comm_rec^ do } if loopcontrol^.loopisok then call(hphilcmdhook,configureop); {connect the ISRs} initrel:=true; end else        RIGHTS LEGEND Use, duplication, or disclosure by the Government is subject to restrictions as set forth in paragraph (b) (3) (B) of the Rights in Technical Data and Computer Software clause in DAR 7-104.9(a). HEWLETT-PACKARD COMPANY Fort Collins, Colora - June 1 , 1981 *) (* update - June 5 , 1985 *) (* release - Jul 12 , 1985 *) (* do *) $MODCAL ON$ $PARTIAL_EVAL ON$ $RANGE OFF$ $DEBUG OFF$ $OVFLCHECK OFF$ $STACKCHECK OFF$ $PAGE$ (************************************************************************) (*  *) (* source - IOLIB:KERNEL.TEXT *) (* object - IOLIB:KERNEL.CODE *) (* *) (** *) (* RELEASED VERSION 3.1 *) (* *) (************************************************************************) (* **********************************************************************) $PAGE$ (************************************************************************) (* *) (*  *) (* *) (* IOLIB KERNEL *) (*  *) (* This is the source code for an external procedures library *) (* to be used for general purpose interfacing on the HP 9826. *) (*  *) (* *) (************************************************************************) (* * *) (* The library consists of 3 primary sets of modules - *) (* *) (* 1. KERNEL modules *) (* ) (* *) (* library - IOLIB *) (* name - KERNEL *) (* module(s) - iodec 2. driver modules *) (* 3. IOLIB modules *) (* *) (* The KERNEL modules consist of the follarations *) (* - iocomasm *) (* - general_0 *) (* lowing modules - *) (* *) (* 1. iodeclarations ( contains static r/w space ) *) (* 2. iocomasm *) ( *) (* author - Tim Mikkelsen *) (* phone - 303-226-3800 ext. 2910 *) (* *) (* date * 3. general_0 ( initialization & low level *) (* routines like ioread/iowrite) *) (* The KERNEL modules also have an executable program segement *) (* that gets executed at th       *) (* *) (************************************************************************) $PAGE$ (************************************************************************) (* w Jeff Wu kernel_ No bug sheet. *) (* 07/12/82 initialize Adding temp type for *) (* iodeclarations 626 drivers. *) (*  *) (* *) (* BUG FIX HISTORY - after release 1.0 *) (*  *) (* 0082 T Mikkelsen kernel_ Adding a link for the *) (* 07/23/82 initialize error message function. *) (* iodeclarations See also GENERAL_3. e time it is loaded. This program *) (* initializes the static read/write memory. This program also *) (* allocates the temporary storage for any card that exists - *) (* independent of whether there is or is not a driver for  *) (* *) (* BUG # BY / ON LOC DESCRIPTION *) (* ----- ----------- -------------- ---------------------- *) (* it. *) (* *) (* The driver modules consist of the actual assembly or PASCAL *) (* routines that deal with a specific interface card. There is *) (* also an exe *) (* 1281 T Mikkelsen IODECLARATIONS bad error message. *) (* 01/08/82 No code change in this *) (* cutable program segment for each driver module. *) (* This program searches the select code table in the static r/w *) (* initialized by the KERNEL general_0 module for all select codes *) (* that have the right interface card ( HPIB  module - code change in *) (* GENERAL_3. *) (* *) (* aaaa T Mikkelsen kernel_ No bug sheet. drivers will search *) (* for the 98624 interface ). This program will then set up the *) (* driver tables to point to the correct drivers. *) (* *) (*  *) (* 05/24/82 initialize The CRT and keyboard *) (* select codes were *) (* interchanged. Should *) (*  The rest of the IOLIB modules are high-level modules that are *) (* used by an end user in his/her application program. *) (* *) (* The KERNEL and some set of dr have no effect. *) (* *) (* bbbb T Mikkelsen kernel_ No bug sheet. *) (* 07/09/82 initialize Addiniver modules will exist in the *) (* INITLIB file as object code ( not EXPORT text ). The *) (* export text will reside on the IO file. The rest *) (* of the library will reside on the IO file. g machine id info *) (* iodeclarations for Bob Morain and the *) (* Ganglia drivers. *) (* *) (* j       *) (* end_error_link *) (* *) (* cccc T Mikkelsen iodeclarations Allowing the 98629 card *) (* 08/16/82  *) (* jws J Schmidt iodeclarations Add card id's and types *) (* 03/25/83 general_0 for EPROM programmer *) (* an and the 98628_dsndl as *) (* identifiable cards. *) (* See DC_DRV modules also.*) (* d bubble cards. *) (* Add initialization code.*) (* *) (* jws2 J Schmidt general_0 Add test for internal *) (*  *) (* 0350 T Mikkelsen general_0 Fundamental flaw with *) (* 08/19/82 the dummy drivers. *) (* *) (* 0364  06/28/83 HP-IB present. *) (* *) (* jws3 J Schmidt iodeclarations Deleted io_model_number *) (* 02/09/84 gener T Mikkelsen iodeclarations Addition of SRM errors. *) (* 08/23/82 See also GENERAL_3. *) (* *) (* 0367 T Mikkelsen iolibrary_keral_0 and io_model_name stuff *) (* Added GATOR id, init. *) (* jws4 J Schmidt iodeclarations Added id and init for *) (* 03/05/84 general_0 98644 card nel *) (* 09/22/82 Allow kernel to install *) (* itself - probably will *) (* not be used much. *) ( *) (* *) (* ----------- changes for release 3.1 *) (* jws5 J Schmidt iodeclarations added new temp type *) (* 06/05/85* *) (* tttt T Mikkelsen kbd_rdb Change in the handling *) (* 09/22/82 of the keyboard end of *) (*  to allow space for *) (* default settings on *) (* 98644, 98626 *) (*  line condition from 1.0.*) (* *) (* uuuu T Mikkelsen iodeclarations Differentiate between a *) (* 09/28/82 628 async and 6 *) (* ----------- changes for release 3.23 *) (* DEW Dave Willis iodeclarations added support for the *) (* 09/89 scsi interfaces. *) (* 29 srm *) (* card type (srm/serial). *) (* See also DC_DRV. *) (* ------- changes for release 3.0 *) (*  *) (* DEW1 Dave Willis iodeclarations added support for the *) (* 12/89 HP Parallel interfaces *) (*        *) (* *) (* *) (************************************************************************) $PAGE$ PROGRAM iolibrary_k} ioe_bad_tfr = 7; { improper transfer attempted } ioe_isc_busy = 8; { the select code is busy } ioe_buf_busy = 9; { the buffer is busy } ioe_bad_cnt = 10; { improper transfer ernel ( INPUT , OUTPUT ); { the PROGRAM surrounds the following modules because there needs to be a start address for this set of modules to allow initialization to occur } $PAGE$ (****************************************************************count } ioe_bad_tmo = 11; { bad timeout value } ioe_no_driver = 12; { no driver for this card } ioe_no_dma = 13; { no dma } ioe_no_word = 14; { word o *) (************************************************************************) $PAGE$ (************************************************************************) (* ********) (* *) (* *) (* GENERAL GROUP IODECLARATIONS *) (*  *) (* *) (* REFERENCES : *) (* *) (*  *) (* *) (************************************************************************) MODULE iodeclarations ; { by Tim Mikkelse *) (* 1. 9826 I/O Designers Guide ( Loyd Nelson ) *) (* *) (* 2. 68000 Manual ( Mon date 07/15/81 update 03/05/84 by John Schmidt purpose This module contains the common declarations to be used by the rest of the I/O library. } IMPORT sysglobals; EXPORT CONST iominisc = 0 ; { 0 - 7 itorola ) *) (* *) (* 3. Pascal alpha site ERS ( Roger Ison ) *) (* *) (* nternal } iomaxisc = 31; { 8 - 31 external 8..31 } minrealisc = 7 ; maxrealisc = 31; { 7..31 are real isc.s with temps } io_line_feed = CHR(10); io_carriage_rtn = CHR(13); $PAGE$ { escape code constants } io4. Pascal I/O Library ERS ( Tim Mikkelsen ) *) (* *) (* 5. 9826 HPL EIO & IOD listings ( Bob Hallissy ) *) (* escapecode = -26; ioe_no_error = 0; { no error } ioe_no_card = 1; { no card at select code } ioe_not_hpib = 2; { interface should be hpib } ioe_not_act = 3;  *) (* 6. 9826 HPL Misc. I/O Doc. ( Bob Hallissy ) *) (* *) (* 7. 9826 card documentation ( Mfg. Specs. )  { not active controller } ioe_not_dvc = 4; { should be device not isc } { BUG 1281 TM 1/8/82} ioe_no_space = 5; { no space left in buffer } ioe_no_data = 6; { no data left in buffer       perations not allowed } ioe_not_talk = 15; { not addressed as talker } ioe_not_lstn = 16; { not addressed as listener } ioe_timeout = 17; { a timeout has occurred } ioe_not_sctl = 18;  ); ppe_message = CHR( 96 ); ppd_message = CHR(112 ); talk_constant = 64; listen_constant = 32; $PAGE$ { card type constants } no_card = 0 ; other_card = 1 ; system_card = 2 ; hpib_card = 3 ; gpio_card  { not system controller } ioe_rds_wtc = 19; { bad status or control } ioe_bad_sct = 20; { bad set/clear/test operation } ioe_crd_dwn = 21; { interface card is dead } ioe_eod_seen = 4 ; serial_card = 5 ; graphics_card = 6 ; srm_card = 7 ; { shared resource mgr } { uuuu TM 9/28/82 } bubble_card = 8 ; { bubble memory } { jws 3/25/83} eprom_prgmr = 9 ; { eprom programmer = 22; { end/eod has occured } ioe_misc = 23; { miscellaneous - } { value of param error } ioe_sr_toomany = 304; { too many chars w/o terminator } { 0364 TM 8/23/82 } ioe_dc_fai} { jws 3/25/83} scsi_card = 10; { 09/89 DEW - added SCSI support} pllel_card = 11; { 12/89 DEW1 - added Parallel Centronics support} { card id constants } { } { positive id's l = 306; { dc interface failure } ioe_dc_usart = 313; { USART receive buffer overflow } ioe_dc_ovfl = 314; { receive buffer overflow } ioe_dc_clk = 315; { missing clock }are the actual } { card id's } hp98628_dsndl = -7; { DSN/DL } { cccc TM 8/16/82 } hp98629 = -6; { shared resource mgr } { cccc TM 8/16/82 } hp_datacomm = -5; hp98620 = -4; i ioe_dc_cts = 316; { CTS false too long } ioe_dc_car = 317; { lost carrier disconnect } ioe_dc_act = 318; { no activity disconnect } ioe_dc_conn = 319; { connection not estanternal_kbd = -3; internal_crt = -2; internal_hpib = -1; no_id = 0; hp98624 = 1; { hpib } hp98626 = 2; { serial } hp98622 = 3; { gpio } hp98623 = 4; { bblished } ioe_dc_conf = 325; { bad data bits/par combination } ioe_dc_reg = 326; { bad status /control register } ioe_dc_rval = 327; { control value out of range } ioe_sr_fail = 353; { data licd } hpPARALLEL = 6; { parallel centronics } { DEW1 12/89 } hp98658 = 7; { scsi - also includes hp98265 DEW 09/89 - added SCSI support} hp98625 = 8; { disk } hp98628_async = 20; { hp9862nk failure } { 0364 TM 8/23/82 } no_isc = 255; { used for ioe_isc within io errors } $PAGE$ { hpib message constants } gtl_message = CHR( 1 ); sdc_message = CHR( 4 ); ppc_message = CHR( 5 ); get_messa8 } hpGATOR = 25; { bitmap display -- need number jws3 } hp98253 = 27; { EPROM programmer } { jws 3/25/83 } hp98627 = 28; { graphics } hp98259 = 30; { bubble memory } { jws ge = CHR( 8 ); tct_message = CHR( 9 ); llo_message = CHR( 17 ); dcl_message = CHR( 20 ); ppu_message = CHR( 21 ); spe_message = CHR( 24 ); spd_message = CHR( 25 ); unl_message = CHR( 63 ); unt_message = CHR( 953/25/83 } hp98644 = 66; { serial -- pri. id=2, sec. id=2 jws4 } $PAGE$ TYPE { general declarations } type_isc = iominisc..iomaxisc ; type_device = iominisc..iomaxisc*100+99; io_bit = 0..15 ; io_byte       vl = PROCEDURE ( temp : ANYPTR; line : io_bit ; VAR v : BOOLEAN ); io_proc_vb = PROCEDURE ( temp : ANYPTR; VAR v : BOOLEAN ); io_proc_ptr = PROCEDURE ( temp : ANYPTR; v : ANYPTR ); drv_table ANYPTR ; out_bufptr: ANYPTR ; eirbyte : CHAR ; my_isc : io_byte ; timeout : INTEGER ; { in milliseconds } addressed : io_word ; drv_misc : ARRAY[1..32] OF CHAR ; END; io_temp_type2 _type = RECORD iod_init : io_proc ; iod_isr : ISRPROCTYPE ; iod_rdb : io_proc_vc ; iod_wtb : io_proc_c ; iod_rdw : io_proc_vw ; iod_wtw : io_proc_w ; iod_rds : io_proc_vs ; iod_wtc : i= PACKED RECORD myisrib : ISRIB ; user_isr : io_funny_proc; {JPC 2/22/82} user_parm : ANYPTR ; {JPC 2/22/82} card_addr : ANYPTR ; in_bufptr : ANYPTR ; out_bufptr: ANYPTR ; eirbyte  = 0..255 ; io_word = -32768..32767 ; io_string = STRING[255]; io_proc_type = PROCEDURE; errlnk_type = PROCEDURE ( errorcode : INTEGER ; { 0082 TM 7/23/82 } VAR s : io_string ); { 0082 TM 7/23/82 } { card io_proc_s ; iod_end : io_proc_vb ; iod_tfr : io_proc_ptr ; iod_send : io_proc_c; iod_ppoll : io_proc_vc ; iod_set : io_proc_l ; iod_clr : io_proc_l ; iod_test : io_proc_vl ; END; { procedured and type declarations } type_of_card = io_word; type_card_id = io_word; { hpib type declarations } type_hpib_addr = 0..31 ; type_hpib_line = ( ren_line , ifc_line , srq_line , eoi_line , nrfd_line , nda definition for DMA termination procedure } io_funny_proc = RECORD CASE BOOLEAN OF TRUE: ( real_proc : io_proc ); FALSE: ( dummy_pr : ANYPTR ; dummy_sl : ANYPTR ) END; { procedure definition for user EOT/Ic_line , dav_line , atn_line ) ; { serial type declarations } type_parity = ( no_parity , odd_parity , even_parity , zero_parity , one_parity ); type_serial_line= ( rts_line , cts_line , SR procedures } { Note that the current definition of EOT / ISR procedures is that they will execute ( probably ) inside an ISR and will therefore be at that interrupt level. This has several side effects - such as READ from the keyboard not wo dcd_line , dsr_line , drs_line , ri_line , dtr_line ); $PAGE$ { driver declarations } io_proc = PROCEDURE ( temp : ANYPTR ); io_proc_c = PROCEDURE ( temp : ANYPTR; v : CHAR ); io_rking- since they depend on interrupts occuring. The ISR / EOT procedures will work best if they set a flag that the user program will periodically check. Basically this means the user needs to implement his own end-of-line searching. Theproc_vc = PROCEDURE ( temp : ANYPTR; VAR v : CHAR); io_proc_w = PROCEDURE ( temp : ANYPTR; v : io_word ); io_proc_vw = PROCEDURE ( temp : ANYPTR; VAR v : io_word ); io_proc_s = PROCEDURE ( temp  ISR / EOT procedure is allowed to have a NON-ZERO static link. This means it can be a nested procedure. This is potentially dangerous if the user program is no longer in that chain. CAVEAT EMPTOR.  : ANYPTR; reg : io_word ; v : io_word ); io_proc_vs = PROCEDURE ( temp : ANYPTR; reg : io_word ; VAR v : io_word ); io_proc_l = PROCEDURE ( temp : ANYPTR; line : io_bit ); io_proc_ } { interface driver space } io_temp_type = PACKED RECORD myisrib : ISRIB ; user_isr : io_funny_proc; {JPC 2/22/82} user_parm : ANYPTR ; {JPC 2/22/82} card_addr : ANYPTR ; in_bufptr :      : CHAR ; my_isc : io_byte ; timeout : INTEGER ; { in milliseconds } addressed : io_word ; drv_misc : ARRAY[1..128] OF CHAR ; END; io_temp_type3 = PACKED RECORD {jw 7/12/82}{ serial INTR } serial_DMA , serial_FHS , serial_FASTEST , dummy_tfr_2 , { serial OVERLAP } overlap_INTR , overlap_DMA , overlap_FHS , overlap_FASTEST , OVERLAP ) ; actual_tfr_ty myisrib : ISRIB ; {jw 7/12/82} user_isr : io_funny_proc; {JPC 2/22/82} user_parm : ANYPTR ; {JPC 2/22/82} card_addr : ANYPTR ; {jw 7/12/82} in_bufptr : ANYPTR ; pe = ( no_tfr , INTR_tfr , DMA_tfr , BURST_tfr , FHS_tfr ) ; dir_of_tfr = ( to_memory, { input = BOOLEAN false } from_memory { output= BOOLEAN true } ) ; buf_type = PAC {jw 7/12/82} out_bufptr: ANYPTR ; {jw 7/12/82} eirbyte : CHAR ; {jw 7/12/82} my_isc : io_byte ; {jw 7/12/82} timeout : INTEGER ; { in milliseconds KED ARRAY[0..maxint] OF CHAR; buf_info_type = RECORD drv_tmp_ptr : pio_tmp_ptr; active_isc : io_byte; act_tfr : actual_tfr_type ; usr_tfr : user_tfr_type ; b_w_mode : BOOLEAN ; { word = BOOLEAN} addressed : io_word ; {jw 7/12/82} drv_misc : ARRAY[1..160] OF CHAR ; {jw 7/12/82} END; {jw 7/12/82} io_temp_type4 = PACKED RECORD {jws5 6/5/85} myisrib true } end_mode : BOOLEAN ; { eoi = BOOLEAN true } direction : dir_of_tfr ; term_char : -1..255 ; { -1 = no termination char } term_count : INTEGER ; buf_ptr : ^buf_type ; buf_ : ISRIB ; {jws5 6/5/85} user_isr : io_funny_proc; {jws5 6/5/85} user_parm : ANYPTR ; {jws5 6/5/85} card_addr : ANYPTR ; {jws5 6/5/85} in_bufptr : ANYPTR ; size : INTEGER ; buf_empty : ANYPTR ; buf_fill : ANYPTR ; eot_proc : io_funny_proc; {JPC 2/22/82} eot_parm : ANYPTR ; {JPC 2/22/82} dma_priority: BOOLEAN; END; $PAGE$ VAR { d {jws5 6/5/85} out_bufptr: ANYPTR ; {jws5 6/5/85} eirbyte : CHAR ; {jws5 6/5/85} my_isc : io_byte ; {jws5 6/5/85} timeout : INTEGER ; { in milliseconds } ma driver variables - used by DMA_DRV module and by assembly language drivers. ---------- DON'T MOVE ---------- } dma_ch_0 : io_funny_proc ; dma_isc_0 : io_byte ; dma_ch_1 : io_funny_proc ; dma_isc_1 : io_byte ; dma_isaddressed : io_word ; {jws5 6/5/85} drv_misc : ARRAY[1..164] OF CHAR ; {jws5 6/5/85} END; {jws5 6/5/85} pio_tmp_ptr = ^io_temp_type; isc_table_type = RECORD io_drv_ptr: ^drv_tablrib0 : ISRIB ; dma_isrib1 : ISRIB ; dma_here : BOOLEAN; io_work_char : CHAR; { io escape access variables } ioe_result : INTEGER; ioe_isc : INTEGER; { must be integer because the sc could be no sc ( e_type; io_tmp_ptr: pio_tmp_ptr; card_type : type_of_card; user_time : INTEGER; card_id : type_card_id; card_ptr : ANYPTR; END; $PAGE$ { transfer declarations } user_tfr_type = ( dummy_tfr_1 , 255 ) or a device like 701 etc. } isc_table : PACKED ARRAY [type_isc] OF isc_table_type; io_revid : STRING[96]; { revision string - added 2/5/82 - TM meaning - 'IO 1.0 refers to the IO library ( in system.li      END; { of io_find_isc } END; { of iodeclarations } $PAGE$ EXTERNAL MODULE iocomasm ; { by Tim Mikkelsen date 10/29/81 update 10/29/81 purpose This module contains the iocomasm code ( binary functions & dma control ) } IMPOegister : io_word ) : io_word ; PROCEDURE iocontrol ( select_code: type_isc ; register : io_word ; value : io_word); PROCEDURE kernel_initialize; PROCEDURE io_system_reset; IMPLEMENT IMPORT sysglobals , iocomasm ; RT iodeclarations; EXPORT FUNCTION dma_request ( temp : ANYPTR ) : INTEGER; PROCEDURE dma_release ( temp : ANYPTR ); FUNCTION bit_set ( v : INTEGER ; b : INTEGER ) : BOOLEAN ; FUNCTION binand ( x : INTEGER ; y : INTEGER  $PAGE$ { these are dummy driver procedures used by the kernel } PROCEDURE kbd_rdb ( iod_temp : ANYPTR ; VAR value : CHAR ); BEGIN { tttt TM 9/22/82 } IF EOLN(input) THENbrary ) and the kernel code. Each driver module will append an indication of its revision like 'G1.0' for GPIO. So - a typical system would have a io_revid of 'IO 1.0 : D1.0 H1.0 G1.0 S1.0'. known ids - ) : INTEGER ; FUNCTION binior ( x : INTEGER ; y : INTEGER ) : INTEGER ; FUNCTION bineor ( x : INTEGER ; y : INTEGER ) : INTEGER ; FUNCTION bincmp ( x : INTEGER ) : INTEGER ; END; { of iocomasm } $PAGE$ (***************** main io lib 'IO 1.0 : ' dma driver ' D1.0' hpib driver ' H1.0' gpio driver ' G1.0' 628 driver ' S1.0' 626 driver ' R1.0' Parallel driver ' P1.0' DEW1 12/89 } io_error_link : errlnk_t*******************************************************) (* *) (* *) (* GENERAL GROUP GENERAL_0 ype; { error msg extension } { 0082 TM 7/23/82 } { Will be initialized to a call to a proc in kernal_initialize. To extend error messages, copy old proc value into local var and put in your new proc ( type errlnk_type ).  *) (* *) (* *) (************************************************************************) MO Your proc should see if it can handle code and return the error msg string, if it can't it should call your local link. } PROCEDURE io_escape ( my_code : INTEGER ; select_code: INTEGER); FUNCTION io_find_isDULE general_0 ; { by Tim Mikkelsen date 07/15/81 update 03/05/84 by J. Schmidt purpose This module contains the LEVEL 0 GENERAL GROUP procedures. } IMPORT iodeclarations; EXPORT VAR { driver tables } kbd_crt_drivers :c ( iod_temp : ANYPTR ): io_byte; $PAGE$ IMPLEMENT PROCEDURE io_escape ( my_code : INTEGER ; select_code: INTEGER); BEGIN ioe_isc := select_code; ioe_result := my_code; ESCAPE(ioescapecode); END; { of io_escape } FUN drv_table_type; dummy_drivers : drv_table_type; FUNCTION ioread_word ( select_code: type_isc ; register : io_word ) : io_word ; PROCEDURE iowrite_word( select_code: type_isc ; register : io_word ; value : io_word);CTION io_find_isc ( iod_temp : ANYPTR ): io_byte; VAR my_ptr : pio_tmp_ptr; BEGIN IF iod_temp = NIL THEN BEGIN io_find_isc := no_isc ; END ELSE BEGIN my_ptr := iod_temp; io_find_isc := my_ptr^.my_isc; END; { of IF } FUNCTION ioread_byte ( select_code: type_isc ; register : io_word ) : io_byte ; PROCEDURE iowrite_byte( select_code: type_isc ; register : io_word ; value : io_byte); FUNCTION iostatus ( select_code: type_isc ; r      BEGIN READ(value); value:=io_carriage_rtn; END ELSE BEGIN READ(value); END; { of IF EOLN } END; { of kbd_rdb } { tttt TM 9/22/82 } PROCEDURE crt_wtb ( iod_temp : ANYPTR ; valD; $PAGE$ FUNCTION ioread_word ( select_code: type_isc ; register : io_word ) : io_word ; VAR p : ^io_word; BEGIN p := ANYPTR(isc_table[select_code].card_ptr); IF p = NIL THEN BEGIN { error } io_escape(ioe_no_card,seleue : CHAR ); BEGIN WRITE(value); END; { of crt_wtb } PROCEDURE simple_init ( temp : ANYPTR ); BEGIN { this initialization will do nothing } END; { of simple_init } { addition of new dummy drivers ct_code); END ELSE BEGIN p:=ANYPTR(INTEGER(p)+register); ioread_word:=p^; END; { of IF } END; { of ioread_word } PROCEDURE iowrite_word( select_code: type_isc ; register : io_word ; value : io_word); VAR p : ^i 0350 TM 8/19/82 } PROCEDURE dummy_driver( temp : ANYPTR ); { 0350 TM 8/19/82 } BEGIN { 0350 TM 8/19/82 } io_escape(ioe_no_driver,io_find_isc(temp)); END; PROCEDURE do_word; BEGIN p := ANYPTR(isc_table[select_code].card_ptr); IF p = NIL THEN BEGIN { error } io_escape(ioe_no_card,select_code); END ELSE BEGIN p:=ANYPTR(INTEGER(p)+register); p^:=value; END; { of IF } END; { of iowriummy_driver_c( temp : ANYPTR ; dummy : CHAR ); BEGIN { 0350 TM 8/19/82 } dummy_driver(temp); END; PROCEDURE dummy_driver_a( temp : ANYPTR ; ANYVAR dummy : ANYPTR ); BEGIN te_word } FUNCTION ioread_byte ( select_code: type_isc ; register : io_word ) : io_byte ; TYPE mycharptr = ^CHAR; VAR p : ^CHAR; BEGIN p := ANYPTR(isc_table[select_code].card_ptr); IF p = NIL THEN BEGIN { error { 0350 TM 8/19/82 } dummy_driver(temp); END; PROCEDURE dummy_driver_w( temp : ANYPTR ; dummy : io_word ); BEGIN { 0350 TM 8/19/82 } dummy_driver( } io_escape(ioe_no_card,select_code); END ELSE BEGIN ioread_byte:=ORD(mycharptr(ADDR(p^,register))^); END; { of IF } END; { of ioread_word } PROCEDURE iowrite_byte( select_code: type_isc ; register : io_word ; value temp); END; PROCEDURE dummy_driver_dw(temp : ANYPTR ; dummy,d2 : io_word ); BEGIN { 0350 TM 8/19/82 } dummy_driver(temp); END; PROCEDURE dummy_driver_wa(temp : ANYPTR ; dummy : io_wor : io_byte); TYPE mycharptr = ^CHAR; VAR p : ^CHAR; BEGIN p := ANYPTR(isc_table[select_code].card_ptr); IF p = NIL THEN BEGIN { error } io_escape(ioe_no_card,select_code); END ELSE BEGIN p:=ANYPTR(INTEGER(p)+d ; VAR d2 : io_word ); BEGIN { 0350 TM 8/19/82 } dummy_driver(temp); END; PROCEDURE dummy_driver_b( temp : ANYPTR ; dummy : io_bit ); BEGIN register); p^:=CHR(value); END; { of IF } END; { of iowrite_byte } FUNCTION iostatus ( select_code: type_isc ; register : io_word ) : io_word ; VAR value : io_word; BEGIN WITH isc_table[select_code] DO CALL(io_drv_pt { 0350 TM 8/19/82 } dummy_driver(temp); END; PROCEDURE dummy_driver_ba(temp : ANYPTR ; dummy : io_bit ; VAR d2 : BOOLEAN ); BEGIN { 0350 TM 8/19/82 } dummy_driver(temp); ENr^.iod_rds, io_tmp_ptr, register, value); iostatus:=value; END; { of iostatus } PROCEDURE iocontrol ( select_code: type_isc ; register : io_word ; value : io_word); VAR my_value : io_word; BEGIN my_value:=value;      5242880); { dma address $500000 } { let DMA driver module hunt for dma } dma_here := FALSE; END; { of BEGIN } OTHERWISE BEGIN END; { other internal interfaces } END; { of CASE io_isc } END  { get temp space } card_type:=other_card; { note - this card will get TEMP space } END; END { of CASE } ELSE BEGIN IF dummy <= 30 THEN { jws 3/25/83 } CASE dummy of ELSE BEGIN card_type:=no_card; IF (io_isc=7) and not(sysflag.nointhpib) { jws2 6/28/83 } THEN BEGIN NEW(io_tmp_ptr); { get temp space } card_type:=hpib_card; card_id :=internal_hpib; card_pt { jws 3/25/83 } 25: BEGIN { jws3 2/09/84 } card_id:=hpGATOR; { jws3 2/09/84 } card_type:=graphics_card; { jws3 2/09/84 } NEW(io_tmp_ptr); { jws3 2/09/84 } END; WITH isc_table[select_code] DO CALL(io_drv_ptr^.iod_wtc, io_tmp_ptr, register, my_value); END; { of iocontrol } $PAGE$ PROCEDURE end_error_link ( errorcode : INTEGER ; { 0082 TM 7/23/82 } VAR s : io_string ); r :=ANYPTR(HEX('478000')); END ELSE BEGIN IF double THEN BEGIN double := FALSE; END ELSE BEGIN card_ptr := ANYPTR(HEX('600000')+((io_isc MOD 32)*65536)); TRY dummy := ioread_byte(io_isc,1); dummy := dummy M { 0082 TM 7/23/82 } BEGIN { 0082 TM 7/23/82 } s := 'unrecognized error'; { 0082 TM 7/23/82 } END; { of end_error_link } OD 128; { mask off remote id bit } IF dummy <= 8 THEN CASE dummy OF 1: BEGIN card_type:=hpib_card; card_id :=hp98624; NEW(io_tmp_ptr); { get temp space } END; 2: BEGIN card_type { 0082 TM 7/23/82 } PROCEDURE kernel_initialize; VAR io_isc : type_isc; dc_dummy : INTEGER; dummy : INTEGER; double : BOOLEAN; { indicates an int. that takes 2 s.c. } bigtemp : ^io_temp_type2; bigtemp3 : ^io_temp_type3; bigt:=serial_card; card_id :=hp98626; NEW(bigtemp4); {jws5 6/5/85} { get temp space } io_tmp_ptr := ANYPTR(bigtemp4); {jws5 6/5/85} END; 3: BEGIN card_type:=gpio_card; card_id emp4 : ^io_temp_type4; { jws5 06/05/85 } BEGIN io_revid := 'IO 3.2: '; { io library revision/id - jws 8/03/83 } io_error_link := end_error_link; { error msg extension } { 0082 TM 7/23/82 } doubl:=hp98622; NEW(io_tmp_ptr); { get temp space } END; 6: BEGIN { DEW1 12/89 added centronics parallel support } card_type:= pllel_card; card_id := hpPARALLEL; Ne := FALSE; { determine what interfaces are present } FOR io_isc:=iominisc TO iomaxisc DO WITH isc_table[io_isc] DO BEGIN user_time :=0; card_id := no_id; IF io_isc 30 ) AND { jws4 3/5/84 } ( dummy <> 52 ) AND ( dummy<>66 ) AND ( dummy <> 39 ) THEN BEGIN NEW(bigtemp3); { TM 8/20/82 } io_tmp_ptr := ANYPTR(bigtemp3); {  { jws 3/25/83 } card_id:=hp98259; { jws 3/25/83 } card_type:=bubble_card; { jws 3/25/83 } NEW(bigtemp); { jws 3/25/83 } io_tmp_ptr:=ANYPTR(bigtemp); { jws 3/25/83 } END;  TM 8/20/82 } { note - this card WILL get LARGE temp space } card_type:=other_card; END; END; { of IF dummy <= 8 } RECOVER BEGIN IF ( escapecode=-11 ) OR ( escapecode=-12 ) THEN BEGIN { no card at this OTHERWISE { jws 3/25/83 } BEGIN { jws 3/25/83 } NEW(bigtemp3); { jws 3/25/83 } io_tmp_ptr:=ANYPTR(bigtemp3); { jws 3/25/83 } card_type:=other_card;  address } END ELSE BEGIN { some other problem } ESCAPE(escapecode); END; END; { of RECOVER BEGIN } END; { of IF double } END; { of IF io_isc=7 } END; { of IF io_isc NIL THEN WITH io_tmp_ptr^ DO BEGIN; { 367 TM 9/22/82 } BEGIN kernel_initialize; MARKUSER; { 367 TM 9/22/82 } END. { of iolibrary_kernel } driver_c ; iod_ppoll := io_proc_vc (dummy_driver_a); iod_set := dummy_driver_b ; iod_clr := dummy_driver_b ; iod_test := dummy_driver_ba ; { 0350 TM 8/19/82 } END; { of  eirbyte := CHR( 0 ); my_isc := io_isc ; timeout := 0 ; { driver timeout } user_isr.dummy_sl := NIL; user_isr.dummy_pr := NIL; user_parm := NIL; {JPC 2/22/82} END;WITH } { 0350 TM 8/19/82 } { initialize the temp space } FOR io_isc := iominisc TO iomaxisc DO BEGIN { set up dummy drivers for the interfaces } isc_table[io_isc].io_drv_ptr:=ADDR(dummy_dri { of IF THEN WITH BEGIN } END; { of FOR WITH BEGIN } { these two FOR blocks are seperate in case two HPIB interfaces are connected in one machine - no funny user isr's will happen. } FOR io_isc:=iominisc TO iomaxisc DO vers); IF isc_table[io_isc].io_tmp_ptr <> NIL THEN WITH isc_table[io_isc].io_tmp_ptr^ DO BEGIN card_addr := isc_table[io_isc].card_ptr; eirbyte := CHR( 0 ); my_isc := io_isc ; timeout := 0 ; addressed := -1; in_bufptr := NI WITH isc_table[io_isc] DO BEGIN IF io_drv_ptr^.iod_init <> dummy_driver THEN BEGIN CALL ( io_drv_ptr^.iod_init , io_tmp_ptr ); END; { of IF } END; { of FOR WITH BEGIN } { In case - for some messed up reason ( typically this L ; out_bufptr:= NIL ; user_isr.dummy_sl := NIL; user_isr.dummy_pr := NIL; user_parm := NIL; {JPC 2/22/82} myisrib.INTREGADDR:= NIL; END; { of IF WITH io_tmp_ptr^ DO } END; { of FOR DO BEGIN } dma_isribis when the user doesn't call ioinitialize/iouninitialize ) - the dma resources are not relinquished by the init routines then this will free the resources. } IF dma_isc_0 <> no_isc THEN BEGIN dma_release(isc_table[dma_isc_0].io_tm0.INTREGADDR := NIL; dma_isrib1.INTREGADDR := NIL; { note - because of the ISRs - this routine can only be called once - at INITLIB time. If it is called again after that invocation the ISR structure will be in very bad shape and p_ptr); END; { of IF } IF dma_isc_1 <> no_isc THEN BEGIN dma_release(isc_table[dma_isc_1].io_tmp_ptr); END; { of IF } END; { of io_system_reset } END; { of general_0 } $PAGE$ (******************************************** will probably hang the machine } kbd_crt_drivers:=dummy_drivers; WITH kbd_crt_drivers DO BEGIN iod_rdb := kbd_rdb; iod_wtb := crt_wtb; iod_init := simple_init; END; { of WITH } isc_table[1].io_drv_ptr := ADDR(****************************) (* *) (* *) (* IOLIBRARY_KERNEL *) (      TTL IOLIB IOCOMASM - common assembly routines PAGE ******************************************************************************** * * COPYRIGHT (C) 1985, 1985 BY HEWLETT-PACKARD COMPANY * ********************************************NCTION bincmp ( x : INTEGER ) : INTEGER ; SRC FUNCTION binasr ( Object : INTEGER ; SRC Amount_of_shift : INTEGER ) : INTEGER ; SRC FUNCTION binasl ( Object : INTEGER ; SRC ************************************ * * * IOLIB IOCOMASM * * ******************************************************************************** * * * * Library - IOLIB * Module - IOCOMASM * Author - Tim Mikkelsen * Phone  Amount_of_shift : INTEGER ) : INTEGER ; SRC FUNCTION binlsr ( Object : INTEGER ; SRC Amount_of_shift : INTEGER ) : INTEGER ; SRC FUNCTION binlsl ( Object : INTEGER ; SRC - 303-226-3800 ext. 2910 * * Purpose - This set of assembly language * code is intended to be used as * a support module for I/O drivers * * Date - 08/18/81 * Update - 03/25/85 * Release - 7/1 Amount_of_shift : INTEGER ) : INTEGER ; SRC END; { IOCOMASM } SPC 5 DEF IOCOMASM_iocomasm DEF IOCOMASM_dma_request DEF IOCOMASM_dma_release DEF IOCOMASM_bit_set D2/85 * * * Source - IOLIB:COMASM.TEXT * Object - IOLIB:COMASM.CODE * * ******************************************************************************** * * * RELEASED * VERSION 3.1 * * ************************************EF IOCOMASM_binand DEF IOCOMASM_binior DEF IOCOMASM_bineor DEF IOCOMASM_bincmp DEF IOCOMASM_binasr DEF IOCOMASM_binasl DEF IOCOMASM_binlsr DEF IOCOMASM_binlsl PAGE ******************************************************** PAGE ******************************************************************************** * * PASCAL DEFINITION OF MODULE * *********************************************************************************************************************************************** * * SYMBOLS FOR EXPORT - COMMON ASSEMBLY LANGUAGE ROUTINES * * THE SYMBOLS DO NOT HAVE PASCAL ENTRY * POINTS SINCE THEY ARE ONLY USED BY * ASSEMBLY LANGUAGE MODULE***** MNAME IOCOMASM SRC MODULE IOCOMASM; SRC IMPORT iodeclarations; SRC EXPORT SRC FUNCTION dma_request ( temp : ANYPTR ) : INTEGER; SRC PROCEDURE dma_release ( temp : ANYPTR ); S OR WITH EXTERNAL DECLARATIONS * ******************************************************************************** DEF DROPDMA DEF GETDMA DEF TESTDMA DEF LOGINT DEF LOGEOT DEF STBSY  SRC FUNCTION bit_set ( v : INTEGER ; SRC b : INTEGER ) : BOOLEAN ; SRC FUNCTION binand ( x : INTEGER ; SRC y : INTEGER ) : INTEGER ; SR DEF STCLR DEF DMA_STBSY DEF ITXFR DEF ABORT_IO DEF WAIT_TFR DEF CHECK_TFR DEF TIMEREXISTS USED AS PASCAL EXTERNAL PROC DEF TIMED_OUT USED AS PASCAL EXTERNAL PROC C FUNCTION binior ( x : INTEGER ; SRC y : INTEGER ) : INTEGER ; SRC FUNCTION bineor ( x : INTEGER ; SRC y : INTEGER ) : INTEGER ; SRC FU SPC 3 * ***************************************************************************** * * IMPORTED SYMBOLS * ***************************************************************************** * REFA CHECK_TIMER USED TO GET AT TIMER      MOVE.L D1,(SP) push result JMP (A0) return * * binary exclusive or * IOCOMASM_BINEOR EQU * MOVEA.L (SP)+,A0 save return address MOVE.L (SP)+,D0 get last paTIVE BUFFER LEFT AROUND. * * ENTRY: A2.L = TEMP POINTER * * USES: D1,D2,D3 AND ROUTINE DROPDMA (WHICH USES A0) * * HPL ROUTINE ( MODIFIED ) * ******************************************************************************** ABORTram MOVE.L (SP)+,D1 get first param EOR.L D0,D1 perform XOR MOVE.L D1,(SP) push result JMP (A0) return * * binary complement * IOCOMASM_BINCMP_IO TRAP #11 GET INTO SUPERVISOR MODE, SAVE SR scs * scs MOVE SR,-(SP) \ PREVENT INTERRUPTS FOR A MOMENT. ORI #$2700,SR / ABORT_IO3 BSR ITXFR IS THERE A TRANSFER IN PRROUTINE IN POWERUP REFA ASM_FLUSH_ICACHE USED TO FLUSH 68020 AFTER DMA XFR * JWH 9/24/90 : LMODE CHECK_TIMER LMODE ASM_FLUSH_ICACHE LMODE save_dtt1 jwh 9/24/90 TTL IOLIB IOCOMASM - pascal  EQU * MOVEA.L (SP)+,A0 save return address MOVE.L (SP)+,D0 get param NOT.L D0 perform complement MOVE.L D0,(SP) push result JMP (A0) binary functions PAGE * * module initialization * IOCOMASM_IOCOMASM EQU * RTS * * bit test * IOCOMASM_BIT_SET EQU * MOVEA.L (SP)+,A0 save return address MOVE.L (SP)+,D0 get bit return SPC 5 TTL IOLIB IOCOMASM - common equates and definitions PAGE INCLUDE COMDCL TTL IOLIB IOCOMASM - error escape PAGE ****************************************************** # MOVE.L (SP)+,D1 get numeric value CLR.B D2 clear indicator BTST D0,D1 test bit in value BEQ.S BITT_EXIT MOVEQ #1,D2 if bit set se************************** * * Error escapes * ******************************************************************************** CTMO_ERR MOVEQ #TMO_ERR,D0 timeout BRA.S ESC_ERR TERR_C MOVEQ #TCNTERR,D0 bad transt indicator BITT_EXIT MOVE.B D2,(SP) push result JMP (A0) return * * binary and * IOCOMASM_BINAND EQU * MOVEA.L (SP)+,A0 save return address MOVE.L (SP)+,D0 fer specification BRA.S ESC_ERR TERR_B MOVEQ #TFR_ERR,D0 bad transfer specification BRA.S ESC_ERR TERR_D MOVEQ #NO_DMA,D0 DMA not installed * BRA.S ESC_ERR SPC 4 ESC_ERR EXT.L D0 get last param MOVE.L (SP)+,D1 get first param AND.L D0,D1 perform AND MOVE.L D1,(SP) push result JMP (A0) return * * binary inclusive or *  MOVE.L D0,IOE_RSLT(A5) save io error MOVE.B IO_SC(A2),D0 \ get sc for error MOVE.L D0,IOE_SC(A5) / MOVE.W #IOE_ERROR,ESC_CODE(A5) give i/o error TRAP #10 escIOCOMASM_BINIOR EQU * MOVEA.L (SP)+,A0 save return address MOVE.L (SP)+,D0 get last param MOVE.L (SP)+,D1 get first param OR.L D0,D1 perform OR ape TTL IOLIB IOCOMASM - transfer support PAGE ******************************************************************************** * * ABORT_IO * * USED DURING INITIALIZATION/RESET TO MAKE SURE THERE * IS NO AC     OGRESS? BEQ.S ABORT_IO2 IF NOT, DO NOTHING CMP.B #TT_DMA,D1 ELSE IS IT A DMA? BEQ.S ABORT_IO1 IF NOT, SKIP BSR DROPDMA ELSE FREE UP THE DMA CH, GET COUNT .S CHKWAIT IF SO , THEN WAIT SPC 2 CHKT_IN LEA BUFI_OFF(A2),A4 is there an input tfr MOVE.L (A4),D1 * BRA.S CHKWAIT SPC 3 CHKWAIT BEQ.S CHKEXIT exit if no tfr  MOVE.L D4,TCNT_OFF(A3) fix up count SUB.L D4,D3 fix up actual count TST.B TDIR_OFF(A3) BNE.S AB_OUT ADD.L D3,TFIL_OFF(A3) if input then update fill BRA.S ABORT_ MOVE.L TIMEOUT(A2),D2 get timeout value BEQ.S CHECK_TFR if timeout = 0 then try forever BTST #TIMER_PRESENT,SYSFLAG2 CHECK IF TIMER PRESENT JS 8/3/83 BEQ.S CHKT_TIM IF SO THIO1 AB_OUT ADD.L D3,TEMP_OFF(A3) if output then update empty ABORT_IO1 MOVE.B #255,T_SC_OFF(A3) UNBUSY THE BUFFER CLR.B TACT_OFF(A3) SET TRANSFER TYPE TO NONE CLR.L (A4) clear buffer ptr EN USE IT JS 8/3/83 LSL.L #8,D2 CHKLOOP MOVE.L (A4),D1 check the buffer again BEQ.S CHKEXIT if finished in time then return SUBQ.L #1,D2 decrement BNE.S  BRA ABORT_IO3 see if there is another ABORT_IO2 MOVE (SP)+,SR RESTORE USER MODE scs RTS scs * scs RTE RES CHKLOOP BRA CTMO_ERR CHKEXIT RTS SPC 3 CHKT_TIM MOVE.B #1,-(SP) SET UP TIMER RECORD JS 8/3/83 MOVE.L D2,-(SP) JS 8/3/83 CHKT_TIM1 MOVE.L (A4),D1 TORE INTERRUPT LEVEL & RETURN PAGE ******************************************************************************** * * CHECK_TFR * * ROUTINE TO CHECK FOR ACTIVE TRANSFER IN THE OPPOSITE DIRECTION. * ( this is called b TRANSFER ACTIVE ? JS 8/3/83 BEQ.S CHKT_TIM2 NO -- EXIT JS 8/3/83 PEA (SP) ELSE CHECK TIMER JS 8/3/83 JSR CHECK_TIMER y a tfr routine on cards * that can't do bi-directional tfrs ) * ( gpio and hpib modules use this routine ) * ( with a timeout wait ) * * ENTRY: A2.L = TEMP POINTER * A3.L = BUF CTL BLK P JS 8/3/83 BPL CHKT_TIM1 BRANCH IF NOT TIMED OUT JS 8/3/83 BRA CTMO_ERR ELSE DO TIMEOUT ESCAPE JS 8/3/83 CHKT_TIM2 ADDQ.L #6,SP CLEAN TIMER RECORD FROM SOINTER * * EXIT : IF NOT TRANSFER, RETURN * IF TRANSFER, THEN wait until finished * or until timeout ( if any ) * *************************************************************************TACK JS 8/3/83 RTS AND RETURN JS 8/3/83 PAGE ******************************************************************************** * * WAIT_TFR * * ROUTINE TO CHECK FOR ACTIVE TRANSFE******* CHECK_TFR TST.B TDIR_OFF(A3) base test on direction BNE.S CHKT_IN ( if this is in , check out ) CHKT_OUT LEA BUFO_OFF(A2),A4 IS THERE AN output BUFFER ACTIVE? MOVE.L (A4),D1 BRAR. * ( with a timeout wait ) * * ENTRY: A2.L = TEMP POINTER * * EXIT : IF NOT TRANSFER, RETURN * IF TRANSFER, THEN wait until finished * or until timeout ( if any )      AND RETURN JS 8/3/83 PAGE ******************************************************************************** * * ITXFR * * ROUTINE TO CHECK FOR ACTIVE TRANSFER. * * ENTRY: A2.L = TEMP POINTER * * ********************************************** STCLR BSR ITXFR GET BUFFER POINTER FROM TEMPS BEQ.S STCLR1 IF ALREADY CLEAR, SKIP MOVE.B #255,T_SC_OFF(A3) CLEAR S.C. INDICATOR IN THE BUF CTL  EXIT : IF NOT TRANSFER, RET with zero flag set * IF TRANSFER, RET with not zero * D1.W = ACTUAL TFR TYPE * D2.W = TERMINATING CHAR FROM TEMPS * D3.L = TRANSFER COUNT FROBLK CLR.B TACT_OFF(A3) clear tfr type CLR.L (A4) CLEAR BUF POINTER IN SC TEMPS *RTS SPC 5 ******************************************************************************** * * LOGEOT * * * USES: NO REGS OTHER THAN RETURN VALUES. * * ******************************************************************************** WAIT_TFR BSR ITXFR quick check for tfr BEQ.S WT_DONE and exit M TEMPS * A0.L = DATA POINTER FROM TEMPS ( either emtpy or fill ) * A3.L = BUF CTL BLK POINTER FROM TEMPS * * HPL ROUTINE ( MODIFIED ) * ************************************************************************* MOVE.L TIMEOUT(A2),D6 get timeout value BEQ.S WAIT_TFR if timeout = 0 then try forever BTST #TIMER_PRESENT,SYSFLAG2 IF TIMER PRESENT USE IT JS 8/3/83 BEQ.S WT_TIM BRANCH IF WE HA******* ITXFR LEA BUFI_OFF(A2),A4 IS THERE AN input BUFFER ACTIVE? MOVE.L (A4),D1 BNE.S ITXFR3 IF NOT, SKIP LEA BUFO_OFF(A2),A4 is there an output tfr MOVE.L (A4),D1 VE IT JS 8/3/83 LSL.L #5,D6 WT_LOOP BSR.S ITXFR try BEQ.S WT_DONE if finished in time then return SUBQ.L #1,D6 decrement BNE.S WT_LOOP BRA CTMO BEQ.S ITXFR1 -no ITXFR3 MOVEA.L D1,A3 \ CLR.L D1 ELSE GET BUFFER TYPE WORD MOVE.B TACT_OFF(A3),D1 / CLR.L D2 MOVE.W TCHR_OFF(A3),D2 G_ERR WT_DONE RTS SPC 3 WT_TIM MOVE.B #1,-(SP) SET UP TIMER RECORD JS 8/3/83 MOVE.L D6,-(SP) JS 8/3/83 WT_TIM1 BSR.S ITXFR CHECK FOR ACTIVE TRANSFET TERMINATING CHAR MOVE.L TCNT_OFF(A3),D3 GET COUNT MOVEA.L TEMP_OFF(A3),A0 GET EMPTY POINTER TST.B TDIR_OFF(A3) check direction BNE.S ITXFR2 \ IF INPUT MOVEA.L TFIER JS 8/3/83 BEQ.S WT_TIM2 NONE -- EXIT JS 8/3/83 PEA (SP) CHECK TIMER JS 8/3/83 JSR CHECK_TIMER JS 8/3/83 L_OFF(A3),A0 / THEN GET FILL POINTER ITXFR2 MOVEQ #1,D5 set not zero STCLR1 EQU * ITXFR1 RTS PAGE ******************************************************************************** * * STCLR * *  BPL WT_TIM1 LOOK AGAIN IF NOT TIMED OUT JS 8/3/83 BRA CTMO_ERR ELSE DO TIMEOUT ESCAPE JS 8/3/83 WT_TIM2 ADDQ.L #6,SP CLEAN UP TIMER RECORD JS 8/3/83 RTS  ROUTINE TO SET A BUFFER & SELECT CODE NOT BUSY * * ENTRY: gets buf ptr from ITXFR routine * * assumes only one tfr per select code * * USES: A3,D0 * * HPL ROUTINE ( MODIFIED ) * **********************************      * CALL THE USER PROC AT END OF TRANSFER * * PASCAL ROUTINE * * modified to pass a user parameter: JPC 02/22/82 * ******************************************************************************** LOGEOT LEA T_PR_OFF(A3),A0 ************************************************************* DMA_STBSY MOVE.L A4,DMAISR(A0) SAVE THE TERMINATION ROUTINE CLR.L DMASL(A0) CLEAR THE STATIC LINK * BRA.S STBSY SET THE BUFFER BUSY  point to procedure/static link/parameter H_EOT1 MOVE.L (A0),D0 is there a proc? BEQ.S H_EOT3 skip if not MOVEM.L A1-A4,-(SP) save dedicated regs (8/10/82 JPC) MOVE.L 8( SPC 5 ******************************************************************************** * * STBSY * * ROUTINE TO SET A BUFFER BUSY * * ENTRY: * D0.W = TRANSFER COUNT TO BE PUT IN TCNT_OFF(A2) * A0),-(SP) push the parameter MOVE.L 4(A0),D1 is there a static link? BEQ.S H_EOT2 Roger Ison says it is okay to try MOVE.L D1,-(SP) and call proc with static link H_ AND TO BE ADDED TO E/F COUNT. * A2.L = POINTER TO DRIVER TEMPS * A3.L = POINTER TO BUFFER CTL BLOCK * * HPL ROUTINE ( MODIFIED ) * *****************************************************************************EOT2 MOVEA.L D0,A0 procedure address JSR (A0) call it MOVEM.L (SP)+,A1-A4 restore dedicated regs (8/10/82 JPC) H_EOT3 RTS PAGE ********************************************* STBSY MOVE.L D0,TCNT_OFF(A3) COPY TFR COUNT INTO TEMPS. TST.B TDIR_OFF(A3) \ BNE.S STBSY1 \ MOVE.L A3,BUFI_OFF(A2) MAKE SELECT CODE BUSY BRA.S STBSY2 ************************************** * * LOGINT * * THIS ROUTINE WAS CALLED H_LOG * * CALL THE USER PROC WHEN AN ISR SAYS TO * * PASCAL ROUTINE * * modified to pass a user parameter: JPC 02/22/82 * **************** / STBSY1 MOVE.L A3,BUFO_OFF(A2) / STBSY2 MOVE.B IO_SC(A2),T_SC_OFF(A3) SET UP BUFFER ACTIVE SELECT CODE RTS DONE! TTL IOLIB IOCOMASM - dma support PAGE ********************************************************************************************* LOGINT LEA H_ISR_PR(A2),A0 point to procedure/static link/parameter BRA H_EOT1 call it (if it exists) PAGE *********************************************************************************** * * DMA RESOURCE MANAGEMENT ROUTINES * * ******************************************************************************** SPC 3 ************************************************************************************************************ * * DMA_STBSY * * ROUTINE TO SET A BUFFER BUSY * * ENTRY: * D0.W = TRANSFER COUNT TO BE PUT IN TCNT_OFF(A2) * AND TO BE ADDED TO E/F COUNT. * ******************** * * DMA RESOURCE temporaries * * These resource temporaries need to be aligned with the offsets * generated by the main Pascal library. This is not an automatic * operation - it must be done by hand if AN A0.L = pointer to DMA temps * A2.L = POINTER TO DRIVER TEMPS * A3.L = POINTER TO BUFFER CTL BLOCK * A4.L = POINTER TO TERMINATION ROUTINE * * HPL ROUTINE ( MODIFIED ) * *******************Y new declarations are * added in the iodeclarations in front of the dma resource temps. * ******************************************************************************** DMAFLAG EQU iodeclarations-61 boolean indicating presence of dma h      SEE IF DMA IS INSTALLED BEQ.S DR_FAIL IF NOT, return -1 SUBQ.W #1,D3 turn $82/$81 to $81/$80 ANDI.W #1,D3 determine channel EXT.L D3 MOVE.B IO_SC(A2),DEFINED BY * WHICH DMA CHANNEL WAS GRANTED AND BIT 7=1. * A4.L = ADDRESS OF DMA CHANNEL ARM WORD. * * NOTE: IF THE REQUEST IS FOR INTERNAL HP-IB AS INDICATED BY A1, * ONLY CHANNELMA_SC(A0) ELSE CLAIM THIS CHANNEL FOR CALLER * following 3 lines for 68040 support JWH 2/15/91 btst #3,SYSFLAG2 bne no_40 jsr WRITE_68040 jsr ASM_FLUSH_ICACHE no_40 BRA.S DR_GOOD DR_FAIL MOVE.L  0 WILL BE GRANTED. * * HPL ROUTINE ( MODIFIED ) * ******************************************************************************** GETDMA TRAP #11 GET INTO SUPERVISOR MODE scs * scs MOVE SR,-(SP) ardware SPC 2 DMA0 EQU iodeclarations-8 DMAISR_0 EQU iodeclarations-8 \ DMASL_0 EQU iodeclarations-4 channel 0 temps DMA_SC_0 EQU iodeclarations-9 / SPC 2 DMA1 EQU iodeclarations-18#-1,D3 return -1 DR_GOOD MOVE (SP)+,SR restore int. state MOVE.L D3,(SP) assign return value - channel ( or -1 ) JMP (A4) return addr SPC 4 * * rel DMAISR_1 EQU iodeclarations-18 \ DMASL_1 EQU iodeclarations-14 channel 1 temps DMA_SC_1 EQU iodeclarations-19 / SPC 2 DMAISR EQU 0 isr pointer DMASL EQU 4 stease a dma channel * IOCOMASM_DMA_RELEASE EQU * MOVEA.L (SP)+,A0 save return address MOVEA.L (SP)+,A2 get sc temp MOVEA.L C_ADR(A2),A1 get card ptr PEA (A0) pusatic link DMA_SC EQU -1 allocated s.c. SPC 2 DMACH0 EQU $500000 address of dma channel 0 DMACH1 EQU $500008 address of dma channel 1 ******************************************h return address BRA DROPDMA release it SPC 4 TTL IOLIB IOCOMASM - assembly dma procedures PAGE ******************************************************************************** * * GETDMA ************************************** * * ADDRESS CONSTANTS * ******************************************************************************** H_INT_CA EQU $478000 ADDRESS OF INTERNAL HPIB INTERFACE TTL IOLIB IOCOMASM - * * ROUTINE TO OBTAIN CONTROL OF A DMA CHANNEL * GET EITHER DMA CHANNEL, TRYING FOR CH 1 FIRST. * * ENTR: CONDITIONS ARE THE SAME AS FOR THE tfr DRIVER ENTRY POINT. * * EXIT: IF DMA IS NOT INSTALLED, 'no dma' escape is gpascal dma procedures PAGE * * request a dma channel * IOCOMASM_DMA_REQUEST EQU * MOVEA.L (SP)+,A4 save return address MOVEA.L (SP)+,A2 get sc temp MOVEA.L C_ADR(A2),A1 get caenerated. * IF DMA IS INSTALLED, THE ALGORITHM WAITS FOR A CHANNEL TO * BECOME AVAILABLE AND THEN: * LOGS USE OF DMA CHANNEL * SETS UP ADDRESS AND COUNT REGISTERS. * Crd ptr TRAP #11 GET INTO SUPERVISOR MODE scs * scs MOVE SR,-(SP) JUST IN CASE CALLER DIDN'T DISABLE ORI #$2700,SR INTERRUPTS, I WILL. BSR TESTDMA ONSTRUCTS CARD ARM AND DMA ARM MASKS AS FOLLOWS: * D2.W = DMA ARM BYTE WITH BITS 1, 2 DEFINED BY * CONTENTS OF D1 AND BIT 0 = 1. * D3.B = CARD ENABLE BYTE WITH BITS 0, 1 D     JUST IN CASE CALLER DIDN'T DISABLE ORI #$2700,SR INTERRUPTS, I WILL. CMPI.L #$010001,D0 \ make sure count <=65536 BPL TERR_C / BSR.S TESTDMA SEE IF DMA IS. * * ENTRY: A1 = CARD ADDRESS * * EXIT: IF NO DMA IS INSTALLED, RET with zero flag set * IF DMA IS INSTALLED, RET with not zero set * A0.L = ADDRESS OF DMA FLAG FOR AVAILABLE CHANNEL *  INSTALLED BEQ TERR_D IF NOT, GIVE ERROR MOVE.B IO_SC(A2),DMA_SC(A0) ELSE CLAIM THIS CHANNEL FOR CALLER * added for 68040 support JWH 2/15/91 btst #3,SYSFLAG2 bne not_40 jsr WR D2.L = ADDRESS OF AVAILABLE DMA CHANNEL * D3.B = CARD ENABLE BYTE FOR AVAILABLE CHANNEL * * HPL ROUTINE ( MODIFIED ) * ******************************************************************************** TESTDMA LEA ITE_68040 jsr ASM_FLUSH_ICACHE not_40 MOVEA.L D2,A4 A4 = ADDRESS OF DMA CHANNEL HARDWARE. SPC 1 MOVE.L TEMP_OFF(A3),D2 \ TST.B TDIR_OFF(A3) \ BNE.S GETDMA1 DMAFLAG(A5),A0 \ TST.B (A0) DO RET 1 IF NO DMA BEQ.S TESTDMA_C / CMPA.L #H_INT_CA,A1 IF THIS IS A REQUEST FOR THE INTERNAL BEQ.S TESTDMA_A HP-IB, THEN SET UP ADDRESS MOVE.L TFIL_OFF(A3),D2 / GETDMA1 MOVE.L D2,(A4)+ / SPC 1 SUBQ.L #1,D0 COUNT REGISTERS (COUNT REG MOVE.W D0,(A4)+ MUST BE COUNT CAN'T TRY FOR CH 1 SO SKIP. LEA DMA1(A5),A0 ELSE ASSUME WE CAN GET CH 1 MOVE.L #DMACH1,D2 * tm MOVEQ #$82,D3 MOVE.B #$82,D3 CMPI.B #255,DMA_SC(A0) CAN WE? BEQ.S TESTDMA_B -1) ADDQ.L #1,D0 SPC 2 CLR.W D2 MOVE.B TDIR_OFF(A3),D2 MOVE DIRECTION BIT INTO B2 OF D2 LSL #2,D2 IN ORDER TO CONSTRUCT DMA ARM SPC 2 TST.B T_BW_OFF(A3 IF SO, THEN RET 3 TESTDMA_A LEA DMA0(A5),A0 ELSE ASSUME WE CAN GET CH 0 MOVE.L #DMACH0,D2 * tm MOVEQ #$81,D3 MOVE.B #$81,D3 CMPI.B #255,DMA_SC(A0) CAN WE? BEQ.S TESTDMA_B IF HAR) IF BYTE TRANSFER BEQ.S GETDMA2 THEN SKIP ADDQ.W #2,D2 ELSE SET BIT 1 OF DMA ARM. GETDMA2 TST.B T_DMAPRI(A3) check for dma priority requested BEQ.S GETDMA3 ADDWARE PRESENT BUT BUSY,same as not there CLR D5 RTS TESTDMA_B MOVEQ #1,D5 ELSE WE GOT A CH TESTDMA_C RTS SPC 6 ******************************************************************************** * * DQ.W #8,D2 if set then set pri bit GETDMA3 ADDQ.W #1,D2 SET BIT0 OF DMA ARM MOVE (SP)+,SR scs RTS DROPDMA * * ROUTINE TO FREE UP A DMA CHANNEL * * ENTRY: A2.L = POINTER TO DRIVER TEMPS * * EXIT: D4.W = FINAL DMA CHANNEL COUNT * CHANNEL IS DISARMED. * * USES: A0 * * HPL ROUTINE ( MODIFIED ) *  scs * scs RTE SPC 6 ******************************************************************************** * * TESTDMA * * THIS ROUTINE TESTS FOR PRESENCE OF DMA HARDWARE AND WAITS FOR * A CHANNEL TO BECOME AVAILABLE******************************************************************************** DROPDMA EQU * TRAP #11 scs * scs MOVE SR,-(SP) JUST IN CASE CALLER DIDN'T DISABLE      ointer MOVE.L (A0)+,D4 DISARM CH BY READING ADDRESS CLR.L D4 MOVE.W (A0),D4 GET FINAL COUNT INTO D0 ADD.W #1,D4 FIX UP COUNT TO INDICATE LEFT OVER TFR'S DROPDMA2 MOVE move.l (sp)+,d0 restore d0 move (sp)+,SR and SR also RTS ********************************************************************************* * COPY_68040 JEFF HENDERSHOT 2/15 (SP)+,SR scs RTS scs * scs RTE PAGE * ******************************************************************************* * /91. * * THIS ROUTINE IS CALLED IN CASE WE HAVE A 68040 AND WE ARE * DROPPING A DMA CHANNEL. BASICALLY, ONCE A DMA CHANNEL HAS ACTUALLY * BEEN ASSIGNED, WE HAVE TO FORCE WRITETHROUGH CACHING MODE AND * FLUSH CACHES. WHEN ALL ORI #$2700,SR INTERRUPTS, I WILL. BTST #GOT_68020,SYSFLAG2 CHECK IF WE HAVE 68020 BEQ.S DODROP IF NOT THEN SKIP JSR ASM_FLUSH_ICACHE FLUSH ICACHE ON 68020 MOVE CACHE WRITE_68040 JEFF HENDERSHOT 2/15/91. * * THIS ROUTINE IS CALLED IN CASE WE HAVE A 68040 AND WE HAVE ACTUALLY * CLAIMED A DMA CHANNEL. BASICALLY, ONCE A DMA CHANNEL HAS ACTUALLY * BEEN ASSIGNED, WE HAVE _CTL,D4 GET EXT. CACHE CONTROL WORD ANDI #$63,D4 SET DISABLE MOVE D4,CACHE_CTL TURN CACHE OFF BSET #2,D4 SET ENABLE BIT MOVE D4,CACHE_CTL TURN CACTO FORCE WRITETHROUGH CACHING MODE AND * FLUSH CACHES. WHEN ALL DMA CHANNELS ARE RELEASED WE CAN RESTORE * COPYBACK MODE IF THAT WAS THE MODE WE ENCOUNTERED HERE. * * CALLED BY : DMA_REQUEST and GETDMA, right after a DMA channel hasHE BACK ON DODROP MOVEQ #0,D4 ASSUME DMA CHA ALREADY DROPPED... MOVE.B DMA_SC_0(A5),D0 \ CMP.B IO_SC(A2),D0 / IS IT CH 0? BNE.S DROPDMA0 IF NOT, SKIP LEA DMA0 * actually been claimed. Note - we do not call this from * TESTDMA because TESTDMA does not assign channels * * ALGORITHM: ASSUMES 68040 (PUT TEST BEFORE CALLING) * * IF DTT1 CONTAIN(A5),A4 GET A POINTER TO THE CHANNEL R/W LEA DMACH0,A0 POINT A0 TO CH 0 BRA.S DROPDMA1 GO DO IT SPC 2 DROPDMA0 MOVE.B DMA_SC_1(A5),D0 \ CMP.B IO_SC(A2),D0 S SOMETHING NON-ZERO * SAVE CONTENTS OF DTT1 (IN SAVE_DTT1) * PUT 0 (WRITETHROUGH MODE) IN DTT1 * EXIT ********************************************************************************  / IS IT CH 1? BNE.S DROPDMA2 IF NOT, DO NOTHING LEA DMA1(A5),A4 GET A POINTER TO THE CHANNEL R/W LEA DMACH1,A0 POINT A0 TO CH 1 DROPDMA1 equ * * next 3 lines for 68040 supportSAVE_DTT1 DC.L $00000000 save place for DTT1 * WRITE_68040 trap #11 supervisor mode move.l d0,-(sp) save d0 movec DTT1,d0 grab DTT1 cmpi.l #$00000000,d0 if 0 JWH 2/15/91 btst #3,SYSFLAG2 bne same_old jsr copy_68040 same_old MOVE.B #255,DMA_SC(A4) clear s.c. CLR.L DMASL(A4) clear static link CLR.L DMAISR(A4) clear isr p don't ... beq bag_it bother, already in writethrough move.l d0,SAVE_DTT1 else saveit move.l #0,d0 and force ... movec d0,DTT1 writethrough mode bag_it       DMA CHANNELS ARE RELEASED WE CAN RESTORE * COPYBACK MODE (IF THAT MODE WAS SAVED EARLIER) * * CALLED BY : DROPDMA, right after the channel is released * * ENTRY: A0 contains DMACH0 or DMACH1 * * ALGORITHM: ASSUMES 68040 e.l (sp)+,d0 restore d0 RTS ****************************************************************************** * * TIMEREXISTS: PASCAL FUNCTION TO SEE IF TIMER EXISTS * * FUNCTION TIMEREXISTS: BOOLEAN; EXTERNAL; * * (PUT TEST BEFORE CALLING) * * IF SAVE_DTT1 HAS A NON-ZERO VALUE (COPYBACK MODE) * IF CHANNEL 0 RELEASED * IF CHANNEL 1 NOT IN USE * RESTORE DTT1 *  RETURNS TRUE IF TIMER PRESENT, ELSE FALSE * * J SCHMIDT 8/2/83 * ***************************************************************************** * TIMEREXISTS EQU * BTST #TIMER_PRESENT,SYSFLAG2 CHECK BIT FOR TIMER PRESENT  ZERO OUT SAVE_DTT1 * EXIT * IF CHANNEL 1 RELEASED * IF CHANNEL 0 NOT IN USE * RESTORE DTT1 *  SEQ 4(SP) SET FUNCTION RESULT 0=>TRUE RTS AND RETURN * *************************************************************************** * * TIMED_OUT: PASCAL FUNCTION TO SEE IF TIMEOUT HA ZERO OUT SAVE_DTT1 * EXIT ******************************************************************************** COPY_68040 equ * move.l d0,-(sp) save d0 move.l SAVE_DTT1,d0 cmpi.S OCCURRED * * FUNCTION TIMED_OUT(VAR REC: TIMEOUTREC): BOOLEAN; EXTERNAL; * * TIMEOUTREC= PACKED RECORD * COUNT: INTEGER { SET TO TIMEOUT IN MS } * FIRSTTIME: BOOLEAN; {SET THIS TO l #0,d0 anything there ? beq OUTTA_HERE bail out if not move.l a1,-(sp) a1 needed in either case cmpa.l #DMACH0,a0 was it channel 0 released ? bne hadta_bTRUE FOR FIRST * CALL } * END; * * RETURNS: TRUE IF TIMEOUT PERIOD EXPIRED, ELSE FALSE * * CAUTION: WILL SMASH BOTH PARTS OF TIMEOUTREC PARAMETER * * e_one if not then one lea DMA1(A5),a1 see if .. CMPI.B #$FF,DMA_SC(a1) channel 1 busy BNE DONT if so don't restore DTT1 BRA PUT_IT otherwise do re J SCHMIDT 8/2/83 * * REMOVED ADDQ.L #4,SP AFTER SMI JWS 5/3/84 ***************************************************************************** * TIMED_OUT MOVEA.L (SP)+,A0 SAVE RETURN ADDRESS JSR CHECK_Tstore it hadta_be_one equ * no other choice lea DMA0(A5),a1 CMPI.B #$FF,DMA_SC(a1) channel 0 busy ? BNE DONT if so don't restore DTT1 PUT_IT trap #11 IMER CALL CHECK_TIMER USING PARAMETER ON STK SMI (SP) SET RESULT OF FUNCTION JMP (A0) AND RETURN WITH SP POINTING TO RESULT * ********************************************************************otherwise do save it movec d0,DTT1 d0 has SAVE_DTT1 move.l #0,SAVE_DTT1 clear save spot move (sp)+,SR restore SR also DONT movea.l (sp)+,a1 restore a1 OUTTA_HERE mov********* * * Bit shifting routines * ***************************************************************************** * IOCOMASM_binasr equ * movea.l (sp)+,a0 Save return address move.l (sp)+,d0 Pop # of bits to shift     timer_present and sysflag2 equ's * 03/25/85 JS added got_68020, cache_ctl equ's * * ******************************************************************************** * * HPL CONVENTIONS * * * Much of this code is taken in user ISR: do NOT change the proc/stat link/parm ordering!!! H_ISR_PR EQU 20 ..23 procedure ptr H_ISR_SL EQU 24 ..27 static link H_ISR_PM EQU 28 ..31 parameter C_ADR EQU 32 ..35 card addretact from the 9826 HPL * language system EIO ROM ( extended I/O ROM ). * This was written by Bob Hallissy ( originally John Nairn ). * The Pascal that will be calling this code uses * the stack for parameter passage. The HPss BUFI_OFF EQU 36 ..39 buffer pointer offset BUFO_OFF EQU 40 ..43 buffer pointer offset EIRB_OFF EQU 44 eir byte IO_SC EQU 45 select code ( i.e. 7, 22, etc. ) TIMEOUT EQU 46 ..49 timeout move.l (sp)+,d1 Pop the value to shift asr.l d0,d1 Shift the value move.l d1,(sp) Push the resulting return value jmp (a0) Return IOCOMASM_binlsr equ * movea.l (spL code * uses the Ax and Dx registers for all parameters. * The Pascal driver entry points on the previous pages * take care of getting the parameters into the correct * registers. * * * GENERAL HPL ENTRY/EXIT CONDITIO)+,a0 Save return address move.l (sp)+,d0 Pop # of bits to shift move.l (sp)+,d1 Pop the value to shift lsr.l d0,d1 Shift the value move.l d1,(sp) Push the resulting return value NS: * * A1.L = CARD ADDRESS * A2.L = DRIVER TEMP ADDRESS * UNLESS OTHERWISE INDICATED, THESE REGISTERS ARE UNALTERED. * * * NEW ENTRY/EXIT CONDITIONS FOR PASCAL USE : * * A3.L = BUFFER CONTROL BLOCK ADDRESS *  jmp (a0) Return IOCOMASM_binasl equ * movea.l (sp)+,a0 Save return address move.l (sp)+,d0 Pop # of bits to shift move.l (sp)+,d1 Pop the value to shift asl.l d0,d1  In addition to the A1/A2 convention, Pascal will use * A3 for a pointer to the buffer control block. * The HPL system kept much of the transfer * information in the s.c. temps. * * TIMEOUT(A2) = co Shift the value move.l d1,(sp) Push the resulting return value jmp (a0) Return IOCOMASM_binlsl equ * movea.l (sp)+,a0 Save return address move.l (sp)+,d0 Pop # of bits to ntains timeout information * Timeout was a global temp in HPL and a timeout * generated an error. * In PASCAL each card has a timeout value stored in * its temporary area. A timeout error * shift move.l (sp)+,d1 Pop the value to shift lsl.l d0,d1 Shift the value move.l d1,(sp) Push the resulting return value jmp (a0) Return end  generates an ESCAPE ( which can be trapped ). * * ******************************************************************************** PAGE ******************************************************************************** * * * DRIVER TEMPS TTL IOLIB COMDCL - common equates and definitions PAGE ******************************************************************************** * * modified: 02/22/82 JPC added parm to user EOT & ISR proc's * 08/01/83 JS added  TEMPLATE * * OFFSET FROM A2 * * HPL DECLARATIONS ( MODIFIED ) * * ******************************************************************************** ISR_ENTRY EQU 0 ..19 PASCAL ISR LINK & UNLINK area USER_ISR EQU 20       value * =0 : no timeout * #0 : value of timeout MA_W EQU 50 ..51 word access to my address MA EQU 51 byte access to my address AVAIL_OFF EQU 52 . -1 = no termination character TCNT_OFF EQU 16 ..19 transfer count TBUF_OFF EQU 20 ..23 transfer buffer pointer TBSZ_OFF EQU 24 ..27 transfer buffer maximum size TEMP_OFF EQU 28 ..31 transfer empty poin.?? standard space taken from temps * 52 ..83 normal cards ( 32 bytes ) * 52 ..179 98628 card ( 128 bytes ) PAGE ******************************************************************************** * * ter pointer TFIL_OFF EQU 32 ..35 transfer fill pointer T_PR_OFF EQU 36 ..39 transfer pointer to eot procedure * NIL no procedure T_SL_OFF EQU 40 ..43 transfer eot proc static link T_PM_OFF  TRANSFER OFFSETS IN BUFFER CONTROL BLOCK * * OFFSET FROM A3 * * PASCAL DECLARATION * ******************************************************************************** TTMP_OFF EQU 0 ..3 pointer to driver temp offset T_SCEQU 44 ..47 transfer eot proc parameter T_DMAPRI EQU 48 dma priority request * * TRANSFER EQUATES * TT_INT EQU 1 interrupt TT_DMA EQU 2 DMA TT_BURST EQU 3 burst TT_FHS _OFF EQU 5 transfer select code TACT_OFF EQU 7 actual transfer mode TUSR_OFF EQU 9 transfer mode * 00 - not used * 01  EQU 4 fast handshake TTL IOLIB IOCOMASM - escape support PAGE ******************************************************************************** * * EXTERNAL REFERANCES for escape * ********************************************serial DMA * 02 serial FHS * 03 serial FASTEST ( DMA or FHS ) * 04 - not used * ---------------- * ************************************ REFA iodeclarations reference the io lib var. area REFA sysglobals SPC 2 ******************************************************************************** * * Escape code values * ************** 05 overlp INTR * 06 overlp DMA * 07 overlp FHS ( BURST ) * 08 overlp FASTEST ( DMA or BURST ) * ****************************************************************** NO_CARD EQU 1 no interface NOT_HPIB EQU 2 not an hpib interface NO_ACTL EQU 3 no active controller NO_DVC EQU 09 overlp OVERLAP ( DMA or INTR ) T_BW_OFF EQU 10 transfer byte/word indicator * 0 = byte / 1 = word TEND_OFF EQU 11 transfer EOI/END indicator *  4 sc ( not device ) specified NO_SPACE EQU 5 not enough space in the buffer NO_DATA EQU 6 not enough data left in the buffer TFR_ERR EQU 7 tfr error SC_BU 0 = no eoi / 1 = eoi sent or searched for TDIR_OFF EQU 13 transfer direction * 0 = input / 1 = output TCHR_OFF EQU 14 ..15 transfer terminate character * SY EQU 8 sc is currently busy BUF_BUSY EQU 9 the buffer is busy TCNTERR EQU 10 bad count BADTMO EQU 11 bad timeout value NO_DRV EQU 12       asm_adelement,fltpthdw lmode asm_adelement,fltpthdw rorg 0 **************************************************************************** * * The following are the addresses of the coefficients used in the evaluation * of transcendental function to get the status word at minuszero equ $80000000 top 32 bits of the real value -0 flpt_cardaddr equ $5c0000 address of floating pt card flpt_id equ $1 offset of the ID byte/write reset s. * cff_loga equ $3c26 LOG coefficients cff_logb equ $3c3e cff_expp equ $3c56 EXP coefficients cff_expq equ $3c6e cff_sin equ $3c8e SIN/COS coefficients cff_atnp flpt_initmask equ $00000008 UEN flag set; RM to nearest flpt_extracttrap equ $00000007 mask for extracting the exception type flpt_card_id equ $0a float card ID byte SFB * * Values returned by the 16081 FPU if an er no driver NO_DMA EQU 13 no dma installed NO_WORD EQU 14 no word transfers allowed NOT_TALK EQU 15 not addressed as talker NOT_LSTN EQU 16 not addresseequ $3d66 ATN coefficients cff_atnq equ $3d86 * * The following are address of tables used in the BCD <-> real conversions * and in the evaluation of x^y. * tb_pwt equ $3658 BCD <-> real tables tb_pwt8 d as listener TMO_ERR EQU 17 timeout NO_SCTL EQU 18 not system controller BAD_RDS EQU 19 bad read status / write control BAD_SCT EQU 20 bad set/clear/test C equ $3698 tb_pwt4 equ $36b8 tb_pwtt equ $36d8 tb_auxpt equ $3ae0 tb_bcd equ $3b28 tb_bin equ $3bc2 * * Pascal Workstation Escapecodes * esc_flpt_divzer equ -5 divide by RD_DWN EQU 21 interface is dead EOD_SEEN EQU 22 end of data has happened IO_MISC EQU 23 misc. error SPC 3 IOE_ERROR EQU -26 io sub system error escape codzero esc_flpt_over equ -6 overflow esc_flpt_under equ -7 underflow esc_flpt_sincos equ -15 bad argument - sine/cosine esc_flpt_natlog equ -16 bad argument - natural log esc_flpt_sqrt eqe SPC 3 IOE_RSLT EQU IODECLARATIONS-66 IOE_SC EQU IODECLARATIONS-70 SPC 3 ESC_CODE EQU SYSGLOBALS-2 RCVR_BLK EQU SYSGLOBALS-10 TIMER_PRESENT EQU 1 JS 8/1/83 SYSFLAG2 BIT -- 0=>TIMER PRESENT GOT_68020 EQU 4 u -17 bad argument - square root esc_flpt_relbcd equ -18 bad argument - real/BCD conversion esc_flpt_bcdrel equ -19 bad argument - BCD/real conversion esc_flpt_misc equ -29 misc floating poi JS 3/25/85 SYSFLAG2 BIT -- 1=>68020 PRESENT SYSFLAG2 EQU $FFFFFEDA JS 8/1/83 CACHE_CTL EQU $5F400E JS 3/25/85 nt error **************************************************************************** * * The following are some constants that relate to the floating point card. * status equ $21 offset of the FPU protocol status byte q * * FILE: allreals * * This file contains the math routines for the Pascal Workstation. * Major modifications for the 98635A card (hardware floating point) were * done by Paul Beiser March 25, 1984. * sprint nosyms refa sysglobals refa  equ 3 bit postion for the q bit in bogus4 equ $18 offset to do 4 bogus word reads bogus4s equ $16 offset for 6 word reads: 4 bogus and 2 *      ror occurred. * flpt_under equ 1 floating point underflow flpt_over equ 2 floating point overflow flpt_divzero equ 3 floating point divide-by-zero flpt_illegal equ 4 i060 divl_f0_f2 equ $4062 divl_f0_f4 equ $4064 divl_f0_f6 equ $4066 divl_f2_f0 equ $4068 divl_f2_f2 equ $406a divl_f2_f4 equ $406c divl_f2_f6 equ $406e divl_f4_f0 equ $4070 divl_f4_f2 llegal floating point instruction flpt_invalid equ 5 invalid floating point operation flpt_inexact equ 6 inexact floating point result flpt_notdoc equ 7 not furnished by National * * Offsets  equ $4072 divl_f4_f4 equ $4074 divl_f4_f6 equ $4076 divl_f6_f0 equ $4078 divl_f6_f2 equ $407a divl_f6_f4 equ $407c divl_f6_f6 equ $407e negl_f0_f0 equ $4080 negl_f0_f2 equ $408from "flpt_cardaddr" for the operations to the floating point card. * addl_f0_f0 equ $4000 addl_f0_f2 equ $4002 addl_f0_f4 equ $4004 addl_f0_f6 equ $4006 addl_f2_f0 equ $4008 addl_f2_f2 equ $400a addl_f2 negl_f0_f4 equ $4084 negl_f0_f6 equ $4086 negl_f2_f0 equ $4088 negl_f2_f2 equ $408a negl_f2_f4 equ $408c negl_f2_f6 equ $408e negl_f4_f0 equ $4090 negl_f4_f2 equ $4092 negl_f4_f4 2_f4 equ $400c addl_f2_f6 equ $400e addl_f4_f0 equ $4010 addl_f4_f2 equ $4012 addl_f4_f4 equ $4014 addl_f4_f6 equ $4016 addl_f6_f0 equ $4018 addl_f6_f2 equ $401a addl_f6_f4 equ  equ $4094 negl_f4_f6 equ $4096 negl_f6_f0 equ $4098 negl_f6_f2 equ $409a negl_f6_f4 equ $409c negl_f6_f6 equ $409e absl_f0_f0 equ $40a0 absl_f0_f2 equ $40a2 absl_f0_f4 equ $40a4  $401c addl_f6_f6 equ $401e subl_f0_f0 equ $4020 subl_f0_f2 equ $4022 subl_f0_f4 equ $4024 subl_f0_f6 equ $4026 subl_f2_f0 equ $4028 subl_f2_f2 equ $402a subl_f2_f4 equ $402c subl_f2_absl_f0_f6 equ $40a6 absl_f2_f0 equ $40a8 absl_f2_f2 equ $40aa absl_f2_f4 equ $40ac absl_f2_f6 equ $40ae absl_f4_f0 equ $40b0 absl_f4_f2 equ $40b2 absl_f4_f4 equ $40b4 absl_f4_f6 f6 equ $402e subl_f4_f0 equ $4030 subl_f4_f2 equ $4032 subl_f4_f4 equ $4034 subl_f4_f6 equ $4036 subl_f6_f0 equ $4038 subl_f6_f2 equ $403a subl_f6_f4 equ $403c subl_f6_f6 equ equ $40b6 absl_f6_f0 equ $40b8 absl_f6_f2 equ $40ba absl_f6_f4 equ $40bc absl_f6_f6 equ $40be addf_f0_f0 equ $40c0 addf_f0_f1 equ $40c2 addf_f0_f2 equ $40c4 addf_f0_f3 equ $40c6 ad$403e mull_f0_f0 equ $4040 mull_f0_f2 equ $4042 mull_f0_f4 equ $4044 mull_f0_f6 equ $4046 mull_f2_f0 equ $4048 mull_f2_f2 equ $404a mull_f2_f4 equ $404c mull_f2_f6 equ $404e mull_f4_f0df_f0_f4 equ $40c8 addf_f0_f5 equ $40ca addf_f0_f6 equ $40cc addf_f0_f7 equ $40ce addf_f1_f0 equ $40d0 addf_f1_f1 equ $40d2 addf_f1_f2 equ $40d4 addf_f1_f3 equ $40d6 addf_f1_f4 eq equ $4050 mull_f4_f2 equ $4052 mull_f4_f4 equ $4054 mull_f4_f6 equ $4056 mull_f6_f0 equ $4058 mull_f6_f2 equ $405a mull_f6_f4 equ $405c mull_f6_f6 equ $405e divl_f0_f0 equ $4u $40d8 addf_f1_f5 equ $40da addf_f1_f6 equ $40dc addf_f1_f7 equ $40de addf_f2_f0 equ $40e0 addf_f2_f1 equ $40e2 addf_f2_f2 equ $40e4 addf_f2_f3 equ $40e6 addf_f2_f4 equ $40e8 addf      equ $4150 subf_f1_f1 equ $4152 subf_f1_f2 equ $4154 subf_f1_f3 equ $4156 subf_f1_f4 equ $4158 subf_f1_f5 equ $415a subf_f1_f6 equ $415c subf_f1_f7 equ $415e subf_f2_f0 equ $4u $41d8 mulf_f1_f5 equ $41da mulf_f1_f6 equ $41dc mulf_f1_f7 equ $41de mulf_f2_f0 equ $41e0 mulf_f2_f1 equ $41e2 mulf_f2_f2 equ $41e4 mulf_f2_f3 equ $41e6 mulf_f2_f4 equ $41e8 mulf160 subf_f2_f1 equ $4162 subf_f2_f2 equ $4164 subf_f2_f3 equ $4166 subf_f2_f4 equ $4168 subf_f2_f5 equ $416a subf_f2_f6 equ $416c subf_f2_f7 equ $416e subf_f3_f0 equ $4170 subf_f3_f1 _f2_f5 equ $41ea mulf_f2_f6 equ $41ec mulf_f2_f7 equ $41ee mulf_f3_f0 equ $41f0 mulf_f3_f1 equ $41f2 mulf_f3_f2 equ $41f4 mulf_f3_f3 equ $41f6 mulf_f3_f4 equ $41f8 mulf_f3_f5 equ _f2_f5 equ $40ea addf_f2_f6 equ $40ec addf_f2_f7 equ $40ee addf_f3_f0 equ $40f0 addf_f3_f1 equ $40f2 addf_f3_f2 equ $40f4 addf_f3_f3 equ $40f6 addf_f3_f4 equ $40f8 addf_f3_f5 equ  equ $4172 subf_f3_f2 equ $4174 subf_f3_f3 equ $4176 subf_f3_f4 equ $4178 subf_f3_f5 equ $417a subf_f3_f6 equ $417c subf_f3_f7 equ $417e subf_f4_f0 equ $4180 subf_f4_f1 equ $418 $40fa addf_f3_f6 equ $40fc addf_f3_f7 equ $40fe addf_f4_f0 equ $4100 addf_f4_f1 equ $4102 addf_f4_f2 equ $4104 addf_f4_f3 equ $4106 addf_f4_f4 equ $4108 addf_f4_f5 equ $410a addf_f2 subf_f4_f2 equ $4184 subf_f4_f3 equ $4186 subf_f4_f4 equ $4188 subf_f4_f5 equ $418a subf_f4_f6 equ $418c subf_f4_f7 equ $418e subf_f5_f0 equ $4190 subf_f5_f1 equ $4192 subf_f5_f2 4_f6 equ $410c addf_f4_f7 equ $410e addf_f5_f0 equ $4110 addf_f5_f1 equ $4112 addf_f5_f2 equ $4114 addf_f5_f3 equ $4116 addf_f5_f4 equ $4118 addf_f5_f5 equ $411a addf_f5_f6 equ  equ $4194 subf_f5_f3 equ $4196 subf_f5_f4 equ $4198 subf_f5_f5 equ $419a subf_f5_f6 equ $419c subf_f5_f7 equ $419e subf_f6_f0 equ $41a0 subf_f6_f1 equ $41a2 subf_f6_f2 equ $41a4  $411c addf_f5_f7 equ $411e addf_f6_f0 equ $4120 addf_f6_f1 equ $4122 addf_f6_f2 equ $4124 addf_f6_f3 equ $4126 addf_f6_f4 equ $4128 addf_f6_f5 equ $412a addf_f6_f6 equ $412c addf_f6_subf_f6_f3 equ $41a6 subf_f6_f4 equ $41a8 subf_f6_f5 equ $41aa subf_f6_f6 equ $41ac subf_f6_f7 equ $41ae subf_f7_f0 equ $41b0 subf_f7_f1 equ $41b2 subf_f7_f2 equ $41b4 subf_f7_f3 f7 equ $412e addf_f7_f0 equ $4130 addf_f7_f1 equ $4132 addf_f7_f2 equ $4134 addf_f7_f3 equ $4136 addf_f7_f4 equ $4138 addf_f7_f5 equ $413a addf_f7_f6 equ $413c addf_f7_f7 equ equ $41b6 subf_f7_f4 equ $41b8 subf_f7_f5 equ $41ba subf_f7_f6 equ $41bc subf_f7_f7 equ $41be mulf_f0_f0 equ $41c0 mulf_f0_f1 equ $41c2 mulf_f0_f2 equ $41c4 mulf_f0_f3 equ $41c6 mu$413e subf_f0_f0 equ $4140 subf_f0_f1 equ $4142 subf_f0_f2 equ $4144 subf_f0_f3 equ $4146 subf_f0_f4 equ $4148 subf_f0_f5 equ $414a subf_f0_f6 equ $414c subf_f0_f7 equ $414e subf_f1_f0lf_f0_f4 equ $41c8 mulf_f0_f5 equ $41ca mulf_f0_f6 equ $41cc mulf_f0_f7 equ $41ce mulf_f1_f0 equ $41d0 mulf_f1_f1 equ $41d2 mulf_f1_f2 equ $41d4 mulf_f1_f3 equ $41d6 mulf_f1_f4 eq      $41fa mulf_f3_f6 equ $41fc mulf_f3_f7 equ $41fe mulf_f4_f0 equ $4200 mulf_f4_f1 equ $4202 mulf_f4_f2 equ $4204 mulf_f4_f3 equ $4206 mulf_f4_f4 equ $4208 mulf_f4_f5 equ $420a mulf_f2 divf_f4_f2 equ $4284 divf_f4_f3 equ $4286 divf_f4_f4 equ $4288 divf_f4_f5 equ $428a divf_f4_f6 equ $428c divf_f4_f7 equ $428e divf_f5_f0 equ $4290 divf_f5_f1 equ $4292 divf_f5_f2 4_f6 equ $420c mulf_f4_f7 equ $420e mulf_f5_f0 equ $4210 mulf_f5_f1 equ $4212 mulf_f5_f2 equ $4214 mulf_f5_f3 equ $4216 mulf_f5_f4 equ $4218 mulf_f5_f5 equ $421a mulf_f5_f6 equ  equ $4294 divf_f5_f3 equ $4296 divf_f5_f4 equ $4298 divf_f5_f5 equ $429a divf_f5_f6 equ $429c divf_f5_f7 equ $429e divf_f6_f0 equ $42a0 divf_f6_f1 equ $42a2 divf_f6_f2 equ $42a4  $421c mulf_f5_f7 equ $421e mulf_f6_f0 equ $4220 mulf_f6_f1 equ $4222 mulf_f6_f2 equ $4224 mulf_f6_f3 equ $4226 mulf_f6_f4 equ $4228 mulf_f6_f5 equ $422a mulf_f6_f6 equ $422c mulf_f6_divf_f6_f3 equ $42a6 divf_f6_f4 equ $42a8 divf_f6_f5 equ $42aa divf_f6_f6 equ $42ac divf_f6_f7 equ $42ae divf_f7_f0 equ $42b0 divf_f7_f1 equ $42b2 divf_f7_f2 equ $42b4 divf_f7_f3 f7 equ $422e mulf_f7_f0 equ $4230 mulf_f7_f1 equ $4232 mulf_f7_f2 equ $4234 mulf_f7_f3 equ $4236 mulf_f7_f4 equ $4238 mulf_f7_f5 equ $423a mulf_f7_f6 equ $423c mulf_f7_f7 equ equ $42b6 divf_f7_f4 equ $42b8 divf_f7_f5 equ $42ba divf_f7_f6 equ $42bc divf_f7_f7 equ $42be negf_f0_f0 equ $42c0 negf_f0_f1 equ $42c2 negf_f0_f2 equ $42c4 negf_f0_f3 equ $42c6 ne$423e divf_f0_f0 equ $4240 divf_f0_f1 equ $4242 divf_f0_f2 equ $4244 divf_f0_f3 equ $4246 divf_f0_f4 equ $4248 divf_f0_f5 equ $424a divf_f0_f6 equ $424c divf_f0_f7 equ $424e divf_f1_f0gf_f0_f4 equ $42c8 negf_f0_f5 equ $42ca negf_f0_f6 equ $42cc negf_f0_f7 equ $42ce negf_f1_f0 equ $42d0 negf_f1_f1 equ $42d2 negf_f1_f2 equ $42d4 negf_f1_f3 equ $42d6 negf_f1_f4 eq equ $4250 divf_f1_f1 equ $4252 divf_f1_f2 equ $4254 divf_f1_f3 equ $4256 divf_f1_f4 equ $4258 divf_f1_f5 equ $425a divf_f1_f6 equ $425c divf_f1_f7 equ $425e divf_f2_f0 equ $4u $42d8 negf_f1_f5 equ $42da negf_f1_f6 equ $42dc negf_f1_f7 equ $42de negf_f2_f0 equ $42e0 negf_f2_f1 equ $42e2 negf_f2_f2 equ $42e4 negf_f2_f3 equ $42e6 negf_f2_f4 equ $42e8 negf260 divf_f2_f1 equ $4262 divf_f2_f2 equ $4264 divf_f2_f3 equ $4266 divf_f2_f4 equ $4268 divf_f2_f5 equ $426a divf_f2_f6 equ $426c divf_f2_f7 equ $426e divf_f3_f0 equ $4270 divf_f3_f1 _f2_f5 equ $42ea negf_f2_f6 equ $42ec negf_f2_f7 equ $42ee negf_f3_f0 equ $42f0 negf_f3_f1 equ $42f2 negf_f3_f2 equ $42f4 negf_f3_f3 equ $42f6 negf_f3_f4 equ $42f8 negf_f3_f5 equ  equ $4272 divf_f3_f2 equ $4274 divf_f3_f3 equ $4276 divf_f3_f4 equ $4278 divf_f3_f5 equ $427a divf_f3_f6 equ $427c divf_f3_f7 equ $427e divf_f4_f0 equ $4280 divf_f4_f1 equ $428 $42fa negf_f3_f6 equ $42fc negf_f3_f7 equ $42fe negf_f4_f0 equ $4300 negf_f4_f1 equ $4302 negf_f4_f2 equ $4304 negf_f4_f3 equ $4306 negf_f4_f4 equ $4308 negf_f4_f5 equ $430a negf_f      equ $4372 absf_f3_f2 equ $4374 absf_f3_f3 equ $4376 absf_f3_f4 equ $4378 absf_f3_f5 equ $437a absf_f3_f6 equ $437c absf_f3_f7 equ $437e absf_f4_f0 equ $4380 absf_f4_f1 equ $438 $43fa movfl_f7_f4 equ $43fc movfl_f7_f6 equ $43fe movlf_f0_f0 equ $4400 movlf_f0_f1 equ $4402 movlf_f0_f2 equ $4404 movlf_f0_f3 equ $4406 movlf_f0_f4 equ $4408 movlf_f0_f5 equ $440a movlf_2 absf_f4_f2 equ $4384 absf_f4_f3 equ $4386 absf_f4_f4 equ $4388 absf_f4_f5 equ $438a absf_f4_f6 equ $438c absf_f4_f7 equ $438e absf_f5_f0 equ $4390 absf_f5_f1 equ $4392 absf_f5_f2 f0_f6 equ $440c movlf_f0_f7 equ $440e movlf_f2_f0 equ $4410 movlf_f2_f1 equ $4412 movlf_f2_f2 equ $4414 movlf_f2_f3 equ $4416 movlf_f2_f4 equ $4418 movlf_f2_f5 equ $441a movlf_f2_f6 equ 4_f6 equ $430c negf_f4_f7 equ $430e negf_f5_f0 equ $4310 negf_f5_f1 equ $4312 negf_f5_f2 equ $4314 negf_f5_f3 equ $4316 negf_f5_f4 equ $4318 negf_f5_f5 equ $431a negf_f5_f6 equ  equ $4394 absf_f5_f3 equ $4396 absf_f5_f4 equ $4398 absf_f5_f5 equ $439a absf_f5_f6 equ $439c absf_f5_f7 equ $439e absf_f6_f0 equ $43a0 absf_f6_f1 equ $43a2 absf_f6_f2 equ $43a4  $431c negf_f5_f7 equ $431e negf_f6_f0 equ $4320 negf_f6_f1 equ $4322 negf_f6_f2 equ $4324 negf_f6_f3 equ $4326 negf_f6_f4 equ $4328 negf_f6_f5 equ $432a negf_f6_f6 equ $432c negf_f6_absf_f6_f3 equ $43a6 absf_f6_f4 equ $43a8 absf_f6_f5 equ $43aa absf_f6_f6 equ $43ac absf_f6_f7 equ $43ae absf_f7_f0 equ $43b0 absf_f7_f1 equ $43b2 absf_f7_f2 equ $43b4 absf_f7_f3 f7 equ $432e negf_f7_f0 equ $4330 negf_f7_f1 equ $4332 negf_f7_f2 equ $4334 negf_f7_f3 equ $4336 negf_f7_f4 equ $4338 negf_f7_f5 equ $433a negf_f7_f6 equ $433c negf_f7_f7 equ equ $43b6 absf_f7_f4 equ $43b8 absf_f7_f5 equ $43ba absf_f7_f6 equ $43bc absf_f7_f7 equ $43be movfl_f0_f0 equ $43c0 movfl_f0_f2 equ $43c2 movfl_f0_f4 equ $43c4 movfl_f0_f6 equ $43c6 mo$433e absf_f0_f0 equ $4340 absf_f0_f1 equ $4342 absf_f0_f2 equ $4344 absf_f0_f3 equ $4346 absf_f0_f4 equ $4348 absf_f0_f5 equ $434a absf_f0_f6 equ $434c absf_f0_f7 equ $434e absf_f1_f0vfl_f1_f0 equ $43c8 movfl_f1_f2 equ $43ca movfl_f1_f4 equ $43cc movfl_f1_f6 equ $43ce movfl_f2_f0 equ $43d0 movfl_f2_f2 equ $43d2 movfl_f2_f4 equ $43d4 movfl_f2_f6 equ $43d6 movfl_f3_f0 eq equ $4350 absf_f1_f1 equ $4352 absf_f1_f2 equ $4354 absf_f1_f3 equ $4356 absf_f1_f4 equ $4358 absf_f1_f5 equ $435a absf_f1_f6 equ $435c absf_f1_f7 equ $435e absf_f2_f0 equ $4u $43d8 movfl_f3_f2 equ $43da movfl_f3_f4 equ $43dc movfl_f3_f6 equ $43de movfl_f4_f0 equ $43e0 movfl_f4_f2 equ $43e2 movfl_f4_f4 equ $43e4 movfl_f4_f6 equ $43e6 movfl_f5_f0 equ $43e8 movf360 absf_f2_f1 equ $4362 absf_f2_f2 equ $4364 absf_f2_f3 equ $4366 absf_f2_f4 equ $4368 absf_f2_f5 equ $436a absf_f2_f6 equ $436c absf_f2_f7 equ $436e absf_f3_f0 equ $4370 absf_f3_f1 l_f5_f2 equ $43ea movfl_f5_f4 equ $43ec movfl_f5_f6 equ $43ee movfl_f6_f0 equ $43f0 movfl_f6_f2 equ $43f2 movfl_f6_f4 equ $43f4 movfl_f6_f6 equ $43f6 movfl_f7_f0 equ $43f8 movfl_f7_f2 equ       $441c movlf_f2_f7 equ $441e movlf_f4_f0 equ $4420 movlf_f4_f1 equ $4422 movlf_f4_f2 equ $4424 movlf_f4_f3 equ $4426 movlf_f4_f4 equ $4428 movlf_f4_f5 equ $442a movlf_f4_f6 equ $442c movlf_f4movf_f4_f3 equ $44a6 movf_f4_f4 equ $44a8 movf_f4_f5 equ $44aa movf_f4_f6 equ $44ac movf_f4_f7 equ $44ae movf_f5_f0 equ $44b0 movf_f5_f1 equ $44b2 movf_f5_f2 equ $44b4 movf_f5_f3 _f7 equ $442e movlf_f6_f0 equ $4430 movlf_f6_f1 equ $4432 movlf_f6_f2 equ $4434 movlf_f6_f3 equ $4436 movlf_f6_f4 equ $4438 movlf_f6_f5 equ $443a movlf_f6_f6 equ $443c movlf_f6_f7 equ equ $44b6 movf_f5_f4 equ $44b8 movf_f5_f5 equ $44ba movf_f5_f6 equ $44bc movf_f5_f7 equ $44be movf_f6_f0 equ $44c0 movf_f6_f1 equ $44c2 movf_f6_f2 equ $44c4 movf_f6_f3 equ $44c6 mo$443e movl_f0_f0 equ $4440 movl_f0_f2 equ $4442 movl_f0_f4 equ $4444 movl_f0_f6 equ $4446 movl_f2_f0 equ $4448 movl_f2_f2 equ $444a movl_f2_f4 equ $444c movl_f2_f6 equ $444e movl_f4_f0vf_f6_f4 equ $44c8 movf_f6_f5 equ $44ca movf_f6_f6 equ $44cc movf_f6_f7 equ $44ce movf_f7_f0 equ $44d0 movf_f7_f1 equ $44d2 movf_f7_f2 equ $44d4 movf_f7_f3 equ $44d6 movf_f7_f4 eq equ $4450 movl_f4_f2 equ $4452 movl_f4_f4 equ $4454 movl_f4_f6 equ $4456 movl_f6_f0 equ $4458 movl_f6_f2 equ $445a movl_f6_f4 equ $445c movl_f6_f6 equ $445e movf_f0_f0 equ $4u $44d8 movf_f7_f5 equ $44da movf_f7_f6 equ $44dc movf_f7_f7 equ $44de movf_m_f7 equ $44e0 movf_m_f6 equ $44e4 movf_m_f5 equ $44e8 movf_m_f4 equ $44ec movf_m_f3 equ $44f0 mov460 movf_f0_f1 equ $4462 movf_f0_f2 equ $4464 movf_f0_f3 equ $4466 movf_f0_f4 equ $4468 movf_f0_f5 equ $446a movf_f0_f6 equ $446c movf_f0_f7 equ $446e movf_f1_f0 equ $4470 movf_f1_f1 f_m_f2 equ $44f4 movf_m_f1 equ $44f8 movf_m_f0 equ $44fc movif_m_f7 equ $4500 movif_m_f6 equ $4504 movif_m_f5 equ $4508 movif_m_f4 equ $450c movif_m_f3 equ $4510 movif_m_f2 equ equ $4472 movf_f1_f2 equ $4474 movf_f1_f3 equ $4476 movf_f1_f4 equ $4478 movf_f1_f5 equ $447a movf_f1_f6 equ $447c movf_f1_f7 equ $447e movf_f2_f0 equ $4480 movf_f2_f1 equ $448 $4514 movif_m_f1 equ $4518 movif_m_f0 equ $451c movil_m_f6 equ $4520 movil_m_f4 equ $4524 movil_m_f2 equ $4528 movil_m_f0 equ $452c movfl_m_f6 equ $4530 movfl_m_f4 equ $4534 movfl2 movf_f2_f2 equ $4484 movf_f2_f3 equ $4486 movf_f2_f4 equ $4488 movf_f2_f5 equ $448a movf_f2_f6 equ $448c movf_f2_f7 equ $448e movf_f3_f0 equ $4490 movf_f3_f1 equ $4492 movf_f3_f2 _m_f2 equ $4538 movfl_m_f0 equ $453c lfsr_m_m equ $4540 movf_f7_m equ $4550 movf_f6_m equ $4554 movf_f5_m equ $4558 movf_f4_m equ $455c movf_f3_m equ $4560 movf_f2_m equ  equ $4494 movf_f3_f3 equ $4496 movf_f3_f4 equ $4498 movf_f3_f5 equ $449a movf_f3_f6 equ $449c movf_f3_f7 equ $449e movf_f4_f0 equ $44a0 movf_f4_f1 equ $44a2 movf_f4_f2 equ $44a4  $4564 movf_f1_m equ $4568 movf_f0_m equ $456c movlf_f6_m equ $4570 movlf_f4_m equ $4574 movlf_f2_m equ $4578 movlf_f0_m equ $457c sfsr_m_m equ $4580 page def asm_rmul,asm_rdi     s s@1 branch if not lea flpt_cardaddr,a1 a1 points to the start of the card movem.l d0-d3,movf_m_f3(a1) (d0,d1)->(f3,f2); (d2,d3) -> (f1,f0) tst.w addl_f0_f2(a1) f2 + f0 -> f2 movem.l bogus4s(addr,a1 a1 points to the start of the card movem.l d0-d3,movf_m_f3(a1) (d0,d1)->(f3,f2); (d2,d3) -> (f1,f0) tst.w divl_f0_f2(a1) f2 / f0 -> f2 movem.l bogus4s(a1),d4-d6 4 bogus reads and get error flag btst #qa1),d4-d6 4 bogus reads and get error flag btst #q,d6 the q bit is returned on last read bne flpt_error move.l movf_f2_m(a1),-(sp) return the result (least sig. first) move.l movf_f3_m(a1),-(sp) jmp ,d6 the q bit is returned on last read bne flpt_error move.l movf_f2_m(a1),-(sp) return the result (least sig. first) move.l movf_f3_m(a1),-(sp) jmp (a0) s@7 bsr rdvd move.l d1,-(sp) move.l d0,-(sv,asm_rsub,asm_radd def asm_round,asm_trunc,asm_float def asm_bcd_real,asm_real_bcd,asm_bcdround def asm_pack,asm_unpack def asm_hex,asm_octal,asm_binary def asm_eq,asm_ne,asm_lt,asm_le,asm_gt,asm_ge def asm_sin,asm_cos,asm_ar (a0) s@1 bsr radd do the operation in software move.l d1,-(sp) return the result move.l d0,-(sp) jmp (a0) * * * asm_rsub movea.l (sp)+,a0 movem.l (sp)+,d0-d3 tst.b fltpthdw beq.s s@3 lea ctan,asm_sqrt,asm_exp,asm_ln def asm_addsetrange def asm_flpt_error,asm_flpt_reset asm_flpt_error bra flpt_error asm_flpt_reset bra flpt_reset ******************************************************************************* * * P flpt_cardaddr,a1 a1 points to the start of the card movem.l d0-d3,movf_m_f3(a1) (d0,d1)->(f3,f2); (d2,d3) -> (f1,f0) tst.w subl_f0_f2(a1) f2 - f0 -> f2 movem.l bogus4s(a1),d4-d6 4 bogus reads and get error flag rocedures : asm_radd / asm_rsub / asm_rmul / asm_rdiv * * Description: These are the compiler interface routines for * doing real +, -, *, and /. * * Author : Paul Beiser * * Revisions : 1.0 06/01/81 * btst #q,d6 the q bit is returned on last read bne flpt_error move.l movf_f2_m(a1),-(sp) return the result (least sig. first) move.l movf_f3_m(a1),-(sp) jmp (a0) s@3 bsr rsbt move.l d1,-(sp) move 2.0 09/01/83 For: * o Hardware floating point * * Parameters : 4(sp) - operand1 * 12(sp) - operand2 * * Registers : a0 - return address * a1 - .l d0,-(sp) jmp (a0) * * * asm_rmul movea.l (sp)+,a0 movem.l (sp)+,d0-d3 tst.b fltpthdw beq.s s@5 lea flpt_cardaddr,a1 a1 points to the start of the card movem.l d0-d3,movf_m_f3(a1) (d0,d1)->(f3,f2); (d2,d3) -> (f1,f0) address of the card * d0-d3 - the operands * * Result : The result is returned on the stack. * * Error(s) : Generated in the called routines. * * References : radd, rsbt, rmul, rdvd, flpt_cardaddr, flpt_error tst.w mull_f0_f2(a1) f2 * f0 -> f2 movem.l bogus4s(a1),d4-d6 4 bogus reads and get error flag btst #q,d6 the q bit is returned on last read bne flpt_error move.l movf_f2_m(a1),-(sp) return  * ******************************************************************************* asm_radd movea.l (sp)+,a0 get the return address movem.l (sp)+,d0-d3 get the operands tst.b fltpthdw is fp hardware there beq.the result (least sig. first) move.l movf_f3_m(a1),-(sp) jmp (a0) s@5 bsr rmul move.l d1,-(sp) move.l d0,-(sp) jmp (a0) * * * asm_rdiv movea.l (sp)+,a0 movem.l (sp)+,d0-d3 tst.b fltpthdw beq.s s@7 lea flpt_card     p) jmp (a0) page ******************************************************************************* * * Procedures : asm_sin / asm_cos / asm_arctan / asm_sqrt * asm_exp / asm_ln * * Description: These are the compiler inte point card is not used for any of these * conversions mainly because our hardware does not support * conversions from reals to integers and, in the other * direction, floating point registers would rface routines for * the transendentals. * * Author : Paul Beiser * * Revisions : 1.0 06/01/81 * 2.0 09/01/83 For: * o Hardware floating point * * Parameters : 4(sp)have to be * saved and restored, making the hardware versions not * much faster than the software versions. * ******************************************************************************* asm_float movea.l (sp)+,a0  - operand * * Result : The result is returned on the stack by the * called routine. * * Error(s) : Generated in the called routines. * * References : See text. * ********************************************* return address move.l (sp)+,d0 operand to convert bsr lntrel move.l d1,-(sp) place result on stack move.l d0,-(sp) jmp (a0) asm_round movea.l (sp)+,a0 move.l (sp)+,d0 move.l (sp),d1 bsr r********************************** asm_sin tst.b fltpthdw is hardware there? beq soft_sin software transcendental bra flpt_sin asm_cos tst.b fltpthdw beq soft_cos bra flpt_cos asm_arctan tst.b fltpellnt move.l d0,(sp) jmp (a0) asm_trunc movea.l (sp)+,a0 move.l (sp)+,d0 move.l (sp),d1 bsr rellntt move.l d0,(sp) jmp (a0) page ******************************************************************************* * * Procedures :thdw beq soft_arctan bra flpt_arctan asm_sqrt tst.b fltpthdw beq soft_sqrt bra flpt_sqrt asm_exp tst.b fltpthdw beq soft_exp bra flpt_exp asm_ln tst.b fltpthdw beq soft_ln bra flpt_ln page ***************** asm_bcd_real / asm_real_bcd * * Description: These are the compiler interface routines for * converting between reals and decimals. * * Author : Paul Beiser * * Revisions : 1.0 06/01/81 * * Parameters : asm************************************************************** * * Procedures : asm_float / asm_round / asm_trunc * * Description: These are the compiler interface routines for * converting integers to reals and reals to inte_bcd_real * 4(sp) - address of the result real * 8(sp) - address of the bcd number to convert * asm_real_bcd * 4(sp) - address of the result bcd number * gers. * * Author : Paul Beiser * * Revisions : 1.0 06/01/81 * 2.0 09/01/83 * * Parameters : 4(sp) - operand1 * 12(sp) - operand (if present) * * Registers : a0 - return  8(sp) - address of the real to convert * * Registers : See the text of the code. * * Result : See "Parameters". * * Error(s) : Generated in the called routines. * * References : relbcd, bcdrel * * Miscel address * d0-d1 - the operand(s) * * Result : The result is returned on the stack. * * Error(s) : Generated in the called routines. * * References : lntrel, rellnt, rellntt * * Miscel : The floating : Both bcdrel and relbcd still do software multiplies. * ******************************************************************************* asm_bcd_real movea.l 8(sp),a0 address of the bcd to convert bsr bcdrel return real i     moveq #0,d0 return zero move.l d0,d1 rts * * Shortness is defined as < 17 bits of mantissa. * short2 tst.l d3 test opnd2lo for zero bne.s ts2 move.l d0,d6 test both operandhi for or.l d2,d6 dden one or.w d6,d2 put in hidden one or.w d6,d0 movea.l d7,a0 store result exponent in a0 moveq #0,d7 use d7 for sticky bit tst.l d1 can we do a faster multiply? beq short2 * *  shortness swap d6 and.w #$1f,d6 beq shxsh short times a short move.l d2,d6 test opnd2hi for shortness swap d6 and.w #$1f,d6 bne.s ts2 exg d0,d2 exg d1,d3  B3 B2 B1 B0 * X A3 A2 A1 A0 * --------------------------- * [A0 X B0] (1) * n (d0,d1) movea.l (sp)+,a0 return address movea.l (sp)+,a1 address of the result real move.l d0,(a1)+ move.l d1,(a1) addq.l #4,sp jmp (a0) asm_real_bcd moveq #16,d7 16 digits requested movea.l (sp)+,a1  short opnd in d0-d1 bra longxsh long times a short * * If here then opnd2 is definitely not short. * ts2 move.l d0,d6 swap d6 test opnd1hi for shortness and.w #$1f,d6 bne.s phase1 bra longxsh short1 mo return address movea.l (sp)+,a0 address of result bcd number movea.l (sp),a2 address of number to convert move.l (a2)+,d0 move.l (a2),d1 move.l a1,(sp) bsr relbcd rts page **************************************************ve.l d2,d6 test opnd2hi swap d6 for shortness and.w #$1f,d6 bne.s ph1a exg d0,d2 exg d1,d3 bra longxsh ******************************************************************************* * * 64 bit re***************************** * * Procedure : rmul * * Description: Do a software 64 bit real multiply. * * Author : Paul Beiser / Ted Warren * * Revisions : 1.0 06/01/81 * 2.0 09/01/83 For: * al multiply begins here. * rmul cmp.l #minuszero,d0 check first operand for -0 beq.s retzero return +0 as the answer cmp.l #minuszero,d2 check second operand for -0 beq.s retzero return +0 as the answer move.l #$80007f o To check for -0 as a valid operand * * Parameters : (d0,d1) - first operand * (d2,d3) - second operand * * Registers : d4,d5,d6 - partial products * d7 - sticky bit informf0,d5 mask for exponent evaluation move.l d0,d7 high order opnd1 -> d7 beq.s retzero branch if zero operand swap d0 duplicate high order word into move.w d0,d7 low order word of d7 move.l d2,d6 ation * a0 - result exponent * * Result : The result is returned in (d0,d1). * * Error(s) : Real overflow and real underflow. * * References : err_underflow, err_overflow * * Miscel : No a regist do the same for opnd2 into d6 beq.s retzero branch if zero operand move.l a0,-(sp) a0 must not be altered by this routine swap d2 move.w d2,d6 and.l d5,d6 use mask to put sign in high order and.l d5,d7 ers are destroyed. This is not * quite IEEE because 0 is always returned as * a result regardless of the sign of the operands. * ******************************************************************************* retzero  and exponent in low order word add.l d6,d7 form result sign and exponent at once moveq #$f,d6 mask for removing exponent and.w d6,d0 extract mantissas and.w d6,d2 moveq #$10,d6 mask for inserting hi      [A0 X B1] (2.1) * [A1 X B0] (2.2) * [A1 X B1] (3.1) * [A2 X B0] (3.2) *  (3.3) * move.l d2,d6 swap d6 mulu d1,d6 A0*B2 add.l d6,d5 or.w d5,d7 move.w d4,d5 negx.w d5 neg.w d5 swap d5 * * Phase 4 * (4.1) * move.w d0,d6 mulu  [A0 X B2] (3.3) * [A3 X B0] (4.1) * [A2 X B1] (4.2) * [A0 X B3] (4.3) * d3,d6 A3*B0 add.l d6,d5 * * (4.2) * swap d3 move.l d0,d6 swap d6 mulu d3,d6 A2*B1 swap d3 add.l d6,d5 clr.w d4 addx.w d4,d4 * * (4.3) * move.w d2,d6 mu[A1 X B2] (4.4) * [A3 X B1] (5.1) * [A1 X B3] (5.2) * [A2 x B2] (5.3) * [A2 X B3] lu d1,d6 A0*B3 add.l d6,d5 negx.w d4 neg d4 * * (4.4) * move.l d2,d6 swap d6 swap d1 mulu d1,d6 A1*B2 swap d1 add.l d6,d5 negx.w d4 neg.w d4 swap d4 swap d5 (6.1) * [A3 X B2] (6.2) * [A3 X B3] (7) *------------------------------------------------------------- * PP7 PP6 PP5 PP4 move.w d5,d4 * * Phase 5 * (5.1) * * clr.w d5 move.l d3,d6 swap d6 mulu d0,d6 A3*B1 add.l d6,d4 * * (5.2) * * move.l d1,d6 swap d6 mulu d2,d6  PP3 PP2 PP1 PP0 * * Keep PP4 thru PP7; use PP0 thru PP3 for stickiness. * * Phase 1 * (1) * phase1 move.l d3,d5 check for shortness beq.s short1 ph1a mulu d1,d5 A0*B0 or.w A1*B3 add.l d6,d4 * * (5.3) * * move.l d2,d6 swap d6 swap d0 mulu d0,d6 A2*B2 swap d0 add.l d6,d4 addx.w d5,d5 move.w d5,d6 move.w d4,d5 move.w d6,d4 swap d5 swap d d5,d7 keep track of lost bits for stickiness clr.w d5 discard bits 0-15 swap d5 * * Phase 2 * * (2.1) * move.l d3,d6 swap d6 mulu d1,d6 A0*B1 add.l d6,d4 * * Phase 6 * * (6.1) * move.l d0,d6 swap d6 mulu d2,d6 A2*B3 add.l d6,d4 * * (6.2) * * move.l d2,d6 swap d6 mulu d0,d6 A3*B2 add.l d6,d5 * * (2.2) * clr.w d4 move.l d1,d6 swap d6 mulu d3,d6 A1*B0 add.l d6,d5 addx.w d4,d4 or.w d5,d7 move.w d4,d5 swap d5 * * Phase 3 * (3.1) * * 4 * * Phase 7 * * (7) * move.w d0,d6 mulu d2,d6 A3*B3 swap d6 add.l d6,d4 * * Post normalization after multiplication * p_norm btst #25,d4 bne.s m_norm_1 * * Shift whole mantimove.l d3,d6 swap d6 swap d1 mulu d1,d6 A1*B1 swap d1 add.l d6,d5 * * (3.2) * move.l d0,d6 swap d6 mulu d3,d6 A2*B0 add.l d6,d5 clr.w d4 addx.w d4,d4 * * ssa 4 places right. This avoids 1 shift left. * suba.w #$10,a0 adjust exponent move.l d4,d0 lsr.l #4,d0 and.l #$f,d4 ror.l #4,d4 move.l d5,d1 lsr.l #4,d1 or.l d4,d1 add.l d5,d5 put round and stcky bits in p     ent and mantissa. * or.w d6,d7 place sign with the exponent swap d7 place exponent into top portion add.l d7,d0 aha, hidden bit finally adds back! rts **********************************************************eal divide. * * Author : Sam Sands / Paul Beiser * * Revisions : 1.0 06/01/81 * 2.0 09/01/83 For: * o To check for -0 as a valid operand * * Parameters : (d0,d1) - first operand (di********************** * * Shorter precision multiply when possible. * shxsh swap d0 align 16 bits of mantissa into d0 swap d2 same for d2 lsr.l #5,d0 lsr.l #5,d2 mulu d2,d0 A0*B0 only one multiply vidend) * (d2,d3) - second operand (divisor) * * Result : The result is returned in (d0,d1). * * Error(s) : Real overflow, real underflow, and divide-by-zero. * * References : err_underflow, err_overflow, err_dlace bra.s mround * * Now shift whole mantissa right 5 places. * m_norm_1 move.l d4,d0 lsr.l #5,d0 and.l #$1f,d4 ror.l #5,d4 move.l d5,d1 lsr.l #5,d1 or.l d4,d1 * * Result in (d0,d1). Now round. * mround btst #4,d5 required here swap d0 rotate and mask result into correct bits move.l d0,d1 clr.w d1 lsl.l #5,d1 rol.l #5,d0 and.l #$001fffff,d0 btst #20,d0 test for post-normalize bne.s roundun note: no rounding test round bit beq.s roundun if clear then no rounding to do and.b #$f,d5 get bits lost during last alignment or.b d5,d7 factor into sticky bit mul_rnd2 tst.w d7 test mr. sticky bne.s round_up  possible, too few bits add.l d1,d1 shift mantissa left one position addx.l d0,d0 suba.w #$10,a0 compensate exponent bra roundun * * Long times shorter. * longxsh swap d0 align 16 bits of mantiss if sticky and round then round up btst #0,d1 test lsb of result beq.s roundun else round to even round_up addq.l #1,d1 bcc.s rm_4 addq.l #1,d0 rm_4 btst #21,d0 beq.s roundun test for mantissa ova into d0 lsr.l #5,d0 move.w d3,d5 mulu d0,d5 A0 * B0 or.w d5,d7 keep PP0 in d7 for rounding clr.w d5 swap d5 move.l d3,d6 swap d6 mulu d0,d6 A0 * B1 add.l d6,d5 move.w d5,d4 clr.w erflow lsr.l #1,d0 d1 must already be zero adda.w #$10,a0 * * Extract result sign for later 'or' with the exponent. * roundun move.l a0,d6 get sign swap d6 place in bottom word * * Complete exponent calcu d5 swap d5 move.l d2,d6 swap d6 mulu d0,d6 A0 * B2 add.l d6,d5 swap d4 move.w d5,d4 swap d4 clr.w d5 swap d5 move.w d2,d6 mulu d0,d6 A0 * B3 add.l d6,d5 move.l d5,d0 move.l dlation with tests for overflow and underflow. * move.l a0,d7 exponent with the sign bpl.s no_clear branch if top portion already cleared swap d7 else clear the sign bit clr.w d7 swap d7 no_clear move4,d1 btst #20,d0 test for post-normalize bne.s lxs2 add.w d7,d7 shift entire fraction left addx.l d1,d1 addx.l d0,d0 suba.w #$10,a0 fix exponent lxs2 add.w d7,d7 round bit into carry,a.l (sp)+,a0 restore original value of a0 sub.l #$4000-$10,d7 remove extra bias minus hidden one bmi err_underflow exponent underflow? cmp.w #$7fd0,d7 hidden bit add on later bhi err_overflow or overflow? * * Merge expon leaving stickyness in d7 bcc roundun bra mul_rnd2 possible rounding to do page ******************************************************************************* * * Procedure : rdvd * * Description: Do a software 64 bit r     ivzero * * Miscel : No a registers are destroyed. This is not * quite IEEE because 0 is always returned as * a result regardless of the sign of the operands. * ************************************************ dividend - (quotient * 4th 16 divisor bits) beq.s dv3 mulu d5,d6 sub.l d6,d1 bcc.s dv3 subq.l #1,d0 bcc.s dv3 subq #1,d7 * dv3 swap d3 dividend - (quotient * 3rd 16 divisor bits) mo******************************* * * * This routine called 4 times will produce up to 64 quotient bits * d0-d1 is 64 bit dividend * d2-d3 is 64 bit divisor (should be normalized (bit 31 = 1)) * d4-d5 is 64 bit quotient * dv00 swap d4 ve.w d3,d6 beq.s dv4 mulu d5,d6 swap d1 sub.w d6,d1 swap d1 swap d6 subx.w d6,d0 bcc.s dv4 sub.l #$10000,d0 bcc.s dv4 subq #1,d7 dv4 swap d3 tst.w d7  shift quotient left 16 bits swap d5 move.w d5,d4 * tst.l d0 1st 32 dividend bits / 1st 16 divisor bits beq.s dv7 dv0 swap d2 divu d2,d0 bvc.s normal branch if no overflow * * Had an over restore dividend and quotient if it didn't go bpl.s dv1 * dv5 subq.l #1,d5 decrement quotient bcc.s dv6 subq.l #1,d4 propagate the borrow in the quotient dv6 add.l d3,d1 add divisor back tflow on the divide. Our quotient must be $ffff or $fffe, and the * fixup for the new dividend is derived as follows. * * DVD := Shl16(d0,d1) - Quotient * (d2,d3) * := Shl16(d0,d1) - (2^16-c) * (d2,d3); c = 1 or 2 * := Shl16(d0,d1) - Shl16(d2,do dividend addx.l d2,d0 bcc.s dv5 repeat till dividend >= 0 * (at most twice more if bit 31 of divisor is 1) dv1 rts ******************************************************************************* 3) + c(d2,d3) * := Shl16( (d0,d1) - (d2,d3) ) + c(d2,d3) * swap d2 restore correct order of divisor move.w #$ffff,d5 new quotient sub.l d3,d1 (d0,d1) - (d2,d3) subx.l d2,d0 swap d0 * * Main body of the real divide. * rdvd tst.l d2 check for zero beq err_divzero branch if divisor is a zero cmp.l #minuszero,d2 check for -0 beq err_divzero branch if divisor is a zero * * Check for a zero div shift left by 16 swap d1 move.w d1,d0 clr.w d1 bra.s dv6 fixup up dividend (add back at least once) * * Normal divide - no overflow. Go through standard routine. * normal swap d2 dv7 move.idend. * dvndzer tst.l d0 bne.s checkn divret0 moveq #0,d0 else return a zero result move.l d0,d1 rts checkn cmp.l #minuszero,d0 check for -0 beq.s divret0 * * Prepare mantissas for divide, and save exponents for w d0,d5 16 bits shifted into quotient register swap d1 shift dividend left 16 bits move.w d1,d0 except for remainder in d0 upper clr.w d1 tst.w d5 finish low order part of division: beq.s dv1 later. * procdvd moveq #$000f,d6 masks for the mantissa preparation moveq #$0010,d7 swap d2 get the mantissas move.w d2,-(sp) push the divisor exponent and.w d6,d2 or.w d7,d2 swap d2 swap d0  moveq #0,d7 d7 is used for borrow bit out of dividend move.w d2,d6 dividend - (quotient * 2nd 16 divisor bits) beq.s dv2 mulu d5,d6 sub.l d6,d0 bcc.s dv2 subq #1,d7 * dv2 move.w d3,d6  same for next operand move.w d0,-(sp) push the dividend exponent and.w d6,d0 or.w d7,d0 swap d0 mantissas ready for divide; compute exp * * Divide of the mantissas with the remainder in (d0,d1) * and a 55 bit result      if zero, sticky bit set correctly or.b #1,d3 else set sticky bit * * Do the round and check for overflow and underflow. * rnd btst #1,d3 check round bit beq.s rend branch if nothing to round addq.l overflow * * Miscel : No a registers are destroyed. This is not * quite IEEE because 0 is always returned as * a result regardless of the sign of the operands. * **********************************************#$2,d3 add 1 in the round bit bcc.s rndcon branch if nothing to propagate addq.l #1,d2 else propagate the carry rndcon move.b d3,d0 get the sticky bit lsr.b #1,d0 place into carry bcs.s norml ********************************* first_z move.l d7,d0 if subtracting from zero then the move.l d3,d1 result is operand2 with the sign rts complemented previously * * This is the subtract front end. The second  to enable proper rounding. The result * is generated in (d4,d5). * add.l d1,d1 preshift dividend so quotient lines up right addx.l d0,d0 moveq #11,d7 normalize divisor so that bit 31 = 1 lsl.l d7,d2 rol.l d7,d3 move.l  branch if number not halfway between and.b #$f8,d3 all zero so clear lsb (round to even) norml btst #23,d2 check for overflow beq.s rend if a zero then no overflow lsr.l #1,d2 only bit set d3,d6 and.w #$f800,d3 and.w #$07ff,d6 or.w d6,d2 bsr dv0 inner loop of divide bsr dv00 bsr dv00 bsr dv00 move.l d4,d2 place here so sticky bit can be set move.l d5,d3 * * Compute the new exponent anis #24 because of overflow add.l #$10,d5 adjust exponent accordingly rend tst.l d5 check for underflow bmi err_underflow underflow error handler cmp.w #$7fd0,d5 check for overflow (remember, hidden bit! ) bd sign. * moveq #0,d7 contain the exponent and sign of result move.l d7,d5 exponent calculation registers move.l d7,d6 move.w (sp)+,d5 get dividend exponent move.w (sp)+,d6 get divisor exponent eor.w d5,d6 hi err_overflow overflow error handler * * Splice result together. * lsr.l #1,d2 throw away round and sticky bits roxr.l #1,d3 lsr.l #1,d2 roxr.l #1,d3 or.w d5,d7 place exponent with sign swap d7 add.l d compute sign of result bpl.s possign move.w #$8000,d7 negative sign possign eor.w d5,d6 restore exponents - nice trick move.w #$7ff0,d4 masks for the exponents and.w d4,d5 mask out exponents and.w 7,d2 ah!, hidden bit finally adds back!! move.l d2,d0 place in the correct registers move.l d3,d1 rts page ******************************************************************************* * * Procedure : radd / rsbt * *  d4,d6 sub.l d6,d5 dividend exponent - divisor exponent add.l #$3ff0-$10,d5 bias - hidden bit (hidden bit adds later) * * Normalize mantissa if necessary and compute sticky bit. * possitv btst #22,d2 check leading bit for no Description: Do a software 64 bit real addition/subtraction. * * Author : Sam Sands / Paul Beiser * * Revisions : 1.0 06/01/81 * 2.0 09/01/83 For: * o To check for -0 as a valid operand rmalize bne.s shftd branch if already a one add.l d3,d3 else make it a leading one addx.l d2,d2 sub.l #$10,d5 adjust exponent shftd or.l d0,d1 set sticky bit with remainder beq.s rnd * * Parameters : (d0,d1) - first operand * (d2,d3) - second operand * * Result : The result is returned in (d0,d1). * * Error(s) : Real overflow and real underflow. * * References : err_underflow, err_     operand is subtracted * by complementing its sign. * rsbt cmp.l #minuszero,d2 check second operand for -0 bne.s rsbt1 rts (d0,d1) is the result rsbt1 move.l d2,d7 copy operand2 high order to d7 bne.s suband2 and.w d4,d2 or.w d5,d2 swap d2 swap d6 note: sign flag goes into high part swap d7 move.w #$7ff0,d4 take difference of exponents move.w d4,d5 and.w d6,d4 and.w d7,d5 sub.w d5,d4 beq.s prennonz zero value? rts else (d0,d1) is the result subnonz bchg #31,d7 complement sign bit for subtract bne.s second_p test if plus or minus second_m cmp.l #minuszero,d0 check first operand for -0 bneorm skip prenormalization asr.w #4,d4 faster to shift difference bpl.s add2 larger operand in d0-d1? neg.w d4 otherwise swap move.w d7,d6 use larger exponent exg d0,d2 exg d1,d3 add2.s sec11 branch if not a -0 moveq #0,d0 else make it a plus 0 sec11 move.l d0,d6 copy operand1 high order to d6 beq.s first_z -(d2,d3) is the result bmi.s same_sig if signs are different then set moveq #-1,d7 all ones mask in d7 cmp.w #32,d4 use move.l for >= 32 bge long_sh lsr.l d4,d7 rotate mask and merge to shift ror.l d4,d2 a 64 bit value by N positions ror.l d4,d3  difsigns move.w #-1,d6 subtract flag bra.s add1 prenorm moveq #0,d4 no prenormalization to do bra.s do_it so clear overflow (g,r,s) * * This is the add front end. * radd cmp.l #minuszero,d2 check second oper without looping move.l d3,d4 dump spillover into d3 move.l d2,d5 and.l d7,d2 and.l d7,d3 not.l d7 and.l d7,d5 or.l d5,d3 and.l d7,d4 do_it move.w d6,d5 get result exponent tstand for -0 bne.s radd1 rts (d0,d1) is the result radd1 move.l d2,d7 copy operand2 high order to d7 bne.s add_11 test for zero rts else (d0,d1) is the result add_11 bmi.s seco.l d6 bmi.s sub_it remember subtract flag? * * Add 2 numbers with the same signs. * add_it and.w #$7ff0,d5 mask out exponent move.l #$00200000,d7 mask for mantissa overflow test add.l d3,d1 this is it, sports fans nd_m test sign second_p cmp.l #minuszero,d0 check first operand for -0 bne.s sss11 branch if not a -0 moveq #0,d0 else make it a plus 0 sss11 move.l d0,d6 copy operand1 high order to d6 beq.s first_z  addx.l d2,d0 cmp.l d7,d0 test for mantissa overflow blt.s add3 add.w #16,d5 exponent in bits 15/5 lsr.l #1,d0 everything right and increment roxr.l #1,d1 the exponent roxr.l #1,d4  also test it for zero bmi.s difsigns and check its sign same_sig clr.w d6 clear subtract flag ******************************************************************************* * * Common to both the add and subtract. * add1 bcc.s add3 don't forget to catch the or.w #1,d4 sticky bit add3 cmp.l #$80000000,d4 test for rounding bcs.s add5 if lower then no rounding to do bhi.s add4 if higher then round up btst moveq #$000f,d4 masks for mantissa extraction moveq #$0010,d5 swap d0 clear out exponent of operand1 and.w d4,d0 and put in hidden one bit or.w d5,d0 swap d0 swap d2 do the same for oper #0,d1 otherwise test mr. sticky beq.s add5 add4 addq.l #1,d1 here we are at the roundup bcc.s add5 addq.l #1,d0 cmp.l d7,d0 a word to the wise: test for blt.s add5 mantissa overfl     ent cmp.l d7,d0 normalized yet? bge.s sub1 move.l d0,d4 test for shift by 16 and.l #$001fffe0,d4 test high 16 bits bne.s norm8lop if not 16 , check by 8 sub.w #16,d5 adjust exponent swap d0 branch if exactly 32 shifts cmp.w #55,d4 if shift count is too large then bgt.s shifted_ don't bother sub.w #32,d4 lsr.l d4,d7 ror.l d4,d2 ror.l d4,d3 move.l d3,d4 move.l d2,d5 and.l d swap d1 move.w d1,d0 clr.w d1 bra.s normlopp less than 5 shifts left (maybe 0) norm8lop move.l d0,d4 test for shift by 8 and.l #$001fe000,d4 check 8 high bits bne.s normloop at least one shift sti7,d2 and.l d7,d3 not.l d7 and.l d7,d5 or.l d5,d3 and.l d7,d4 beq.s ls1 or.w #1,d3 ls1 move.l d3,d4 move.l d2,d3 moveq #0,d2 bra do_it zerores tst.l d1 bne.s longnorm if ow when you lsr.l #1,d0 round up during an add add.w #16,d5 exponent in bits 15/5 add5 cmp.w #$7fe0,d5 check for exponent overflow bhi err_overflow tst.w d6 get sign of the result bpl.ll necesarry! sub.w #8,d5 adjust exponent lsl.l #8,d0 rol.l #8,d1 move.b d1,d0 d0 correct clr.b d1 d1 correct normlopp cmp.l d7,d0 must test here - could be done bge.s sub2 s add6 positive result add.w #$8000,d5 copy sign bit add6 swap d5 clr.w d5 for the or bclr #20,d0 hide hidden one or.l d5,d0 exponent into mantissa rts * * Add two numbers with di no rounding necessary normloop add.l d1,d1 this is for post normalizing < 8 times addx.l d0,d0 for any additional shifting subq.w #1,d5 note: this code can be improved cmp.l d7,d0 blt.s normloop bra.s suffering signs. * sub_it lsr.w #4,d5 align in correct location and.w #$07ff,d5 get rid of the sign bit neg.l d4 zero minus overlow subx.l d3,d1 subtract low order subx.l d2,d0 subtract high orderb2 no rounding necessary sub1 cmp.l #$80000000,d4 rounding for subtract bcs.s sub2 same sequence as add bhi.s sub3 btst #0,d1 beq.s sub2 sub3 addq.l #1,d1 round up bcc.s sub2 addq.l  tst.l d0 test for top 21 bits all zero beq zerores at least 21 left shifts necessary bpl.s sign_un did we do it the right way? add.w #$8000,d6 flip sign of result neg.l d1 Note: this p#1,d0 btst #21,d0 mantissa overflow? beq.s sub2 asr.l #1,d0 addq #1,d5 increment exponent (can't overflow) sub2 tst.w d5 test for exponent underflow ble err_underflow lsl.w ath only taken if path negx.l d0 thru prenormalized was taken tst.l d0 check for top 21 bits being zero beq zerores at least 21 left shifts necessary sign_un move.l #$00100000,d7 post normalizat #5,d5 exponent in top so can place in sign add.w d6,d6 get sign roxr.w #1,d5 into exponent swap d5 clr.w d5 for the or bclr #20,d0 hide hidden one or.l d5,d0 ion mask cmp.l d7,d0 test for post normalization bge.s sub1 add.l d4,d4 shift everything left one addx.l d1,d1 shift along guard bit first addx.l d0,d0 time only subq.w #1,d5 decrement expon exponent into mantissa rts shifted_ bclr #20,d0 more than 55 shifts to prenormalize swap d6 so reconstruct larger operand and clr.w d6 return in d0-d1 or.l d6,d0 rts long_sh beq.s ls1      result was zero after subtract, done tst.l d4 check guard bit bmi.s longnorm rts longnorm add.l d4,d4 result nearly zero, shift 21 or more addx.l d1,d1 bcs.s norm21 exact shift by 21 swap d1 e.w d0,d6 and.w #$7ff0,d6 mask out the sign lsr.w #4,d6 sub.w #1022,d6 exponent 1 bigger because of leading one * * Check for boundary conditions. * cmp.w #32,d6 bgt err_intover beq.s check32 -2,147,483,648.5 = test for shift of 16 tst.w d1 bne.s test8 test for shift of 8 sub.w #16,d5 adjust exponent (d1 correct) move.l d1,d7 check which byte first one in swap d7 and.w #$ff00,d7 bne.s lnloop (c1e00000,00100000) tst.w d6 bge.s in32con continue with conversion moveq #0,d0 else return a zero rts * * Finish the conversion. * in32con and.w #$000f,d0 d0 has top 4 bits lsr.l #5,d1 place top b less than 8 shifts left lsl.l #8,d1 else adjust subq.w #8,d5 bra.s lnloop test8 move.w d1,d7 check lower bytes swap d1 d1 in correct order and.w #$ff00,d7 bne.s lnloop its (except hidden one) in d1 ror.l #5,d0 or.l d0,d1 correct except for the hidden bit neg.w d6 add.w #32,d6 1 <= shifts <= 32 bset #31,d1 place in hidden bit lsr.l d6,d1 bcc.s chksign branch if less than 8 shifts left lsl.l #8,d1 else adjust subq.w #8,d5 lnloop subq.w #1,d5 less than 8 shifts left add.l d1,d1 bcc.s lnloop norm21 sub.w #21,d5 adjust exponent swap d1 rotate rounded correctly addq.l #1,d1 round to the nearest bpl.s chksign no overflow tst.w d7 overflow - check for negative result bpl err_intover error if positive 2^31 chksign tst.w d7  left 20 or more places rol.l #4,d1 copy over the boundary move.l d1,d0 and.l #$000fffff,d0 save high 20 bits and.l #$fff00000,d1 save low 12 bits bra sub2 hidden 1 is already gone page ************************** check the sign bpl.s done3 neg.l d1 else convert to negative done3 move.l d1,d0 place result in correct register rts * * Boundary condition checks. * check32 tst.w d0 check sign first bpl er***************************************************** * * Procedure : rellnt * * Description: Convert a real into a 32 bit integer (round). * * Author : Paul Beiser * * Revisions : 1.0 06/01/81 * * Parameters : (d0,d1) r_intover remember, shifted right by 16 and.w #$000f,d0 mantissa of 2^31-.5 = ([1]00000 00100000) bne err_intover definitely WAY too large lsr.l #5,d1 else shift till get LSb bne err_intover if n - real argument * * Registers : d6,d7 - scratch * * Result : The result is returned in d0. * * Error(s) : A real too large for a 32 bit integer. * * References : err_intover * *****************************************on-zero, less than -2^31 - 0.5 bcs err_intover branch if equal to -2^31 - 0.5 move.l #$80000000,d0 else return -2^31 rts page ******************************************************************************* * * Procedure ************************************** rellnt move.w d0,d1 shift everthing to the right by 16 swap d1 d1 is correct clr.w d0 swap d0 d0 is correct move.w d0,d7 save the sign of the number mov: rellntt * * Description: Convert a real into a 32 bit integer (truncation). * * Author : Paul Beiser * * Revisions : 1.0 06/01/81 * * Parameters : (d0,d1) - real argument * * Registers : d6,d7 - scratch * *      E lsr.l #5,d1 shift fractional portion out bne err_intover move.l #$80000000,d0 rts page ******************************************************************************* * * Procedure : lntrel * * Descrf0,d5 bne.s finrit if non-zero, then at most 7 more shifts swap d0 restore mantissa addq.l #8,d4 adjust exponent move.b d0,d1 ror.l #8,d1 d1 is correct lsr.l #8,diption: Convert a 32 bit integer into a real number. * * Author : Paul Beiser * * Revisions : 1.0 06/01/81 * * Parameters : d0 - integer to be converted * * Registers : d4-d7 - scratch * * Result : The 0 d0 is correct bra.s insmask finrit swap d0 restore mantissa insmask move.l #$00200000,d6 mask for the test for normalization cmp.l d6,d0 blt.s shdone if <, d0 correctly lined up loop_7  Result : The result is returned in d0. * * Error(s) : A real too large for a 32 bit integer. * * References : err_intover * ******************************************************************************* rellntt move.w d0,d1 result is returned in (d0,d1). * * Error(s) : None * * References : None * ******************************************************************************* maxlnt move.l #$c1e00000,d0 return -2^31 moveq #0,d1 rts * * Main body of l shift everthing to the right by 16 swap d1 d1 is correct clr.w d0 swap d0 d0 is correct move.w d0,d7 save the sign of the number move.w d0,d6 and.w #$7ff0,d6 mask out the sign lsr.w #4,d6ntrel. * lntrel moveq #0,d7 will hold sign of result and exponent moveq #0,d1 bottom part of mantissa tst.l d0 check if non-zero bne.s nonzero branch if non-zero moveq #0,d0 else returna  sub.w #1022,d6 exponent 1 bigger because of leading one * * Check for boundary conditions. * cmp.w #32,d6 bgt err_intover too big if don't branch beq.s silkcheck skip tst.w d6 for small numbers bgt.s in32czero result move.l d0,d1 rts and return nonzero bpl.s ifposit branch if positive neg.l d0 else convert to positive bvs.s maxlnt branch if had -2^31 move.w #$8000,d7 else sont branch if will convert moveq #0,d0 else return 0 rts * * Place top bits (except for hidden bit) all in d1. * in32cont and.w #$000f,d0 d0 has top 4 bits lsr.l #5,d1 ror.l #5,d0 or.l d0,d1 correct et sign bit in result * * Determine if a 16 bit integer hiding in 32 bits. * ifposit swap d0 check for a 16 bit integer tst.w d0 beq.s int16 branch if a 16 bit integer move.w #1023+20,d4 place in the bias movexcept for the hidden bit * * Finish the conversion. * neg.w d6 add.w #32,d6 1 <= shifts <= 31 bset #31,d1 place in hidden bit lsr.l d6,d1 tst.w d7 check the sign bpl.s done32 neg.l d1 e.w d0,d5 test if have to left shift and.w #$fff0,d5 bne.s highpart branch if first one in top of word move.l #$00100000,d6 mask for the test for normalization swap d0 else restore number loop4 else convert to negative done32 move.l d1,d0 place result in correct register rts * silkcheck tst.w d0 check the sign first bpl err_intover and.w #$000f,d0 bne err_intover if MS bite non-zero, WAY TOO LARG add.l d0,d0 at least 1 and most 4 shifts subq.w #1,d4 cmp.l d6,d0 blt.s loop4 until normalized bra.s shdone highpart move.w d0,d5 see if at least 8 right shifts and.w #$0f      lsr.l #1,d0 roxr.l #1,d1 addq.l #1,d4 cmp.l d6,d0 continue until normalized bge.s loop_7 bra.s shdone * * Have a 16 bit integer to convert, so do it fast. * int16 swap d0 reston bit lsr.w #4,d6 in low 11 bits sub.w #1022,d6 unbiased exponent plus one * * Check if number is too small or large. * bgt.s checknxt branch if check for exponent too large blt.s rnd_zero branch if so small thatre the integer move.w #1023+15,d4 place in the bias move.l #$00100000,d6 mask for the test for normalization lsl.l #5,d0 shift by at least 5 cmp.l d6,d0 see if done bge.s shdone * * At most 15 shifts left. * move return a zero moveq #0,d1 else return + or - 1.0 tst.l d0 determine sign bmi.s retmin move.l #$3ff00000,d0 rts retmin move.l #$bff00000,d0 rts rnd_zero moveq #0,d0 move.l d0,d1 r.l d0,d5 check for shift by 8 and.l #$001fe000,d5 bne.s chk7 branch if 7 or less shifts left lsl.l #8,d0 else shift by 8 subq.w #8,d4 adjust exponent, and finish the shift chk7 cmp.l d6,d0 ts checknxt cmp.w #53,d6 blt.s nearcon continue the round; 1 <= exp <= 52 rts else return with same number * * Compute index for the addition of 0.5. * nearcon neg.w d6 map into correct range add.w # check implied one bge.s shdone lp_7 add.l d0,d0 else shift left subq.w #1,d4 cmp.l d6,d0 blt.s lp_7 continue until normalized * * Splice result together. * shdone subq.w #1,d4 hidden b53,d6 1 <= d6 <= 52 (so can add in a 1) move.w d6,d5 save for later clear of mantissa bits subq.w #1,d6 number of left shifts for the mask moveq #1,d7 mask for the add * * Add 0.5 (in magnitude) to the number it will add back lsl.w #4,d4 place in correct locations or.w d4,d7 place exponent in with sign swap d7 in correct order add.l d7,d0 add in exponent and sign rts page *****************************to be rounded. * cmp.w #32,d6 see if add to d0 or d1 bge.s add0 branch if add to d0 lsl.l d6,d7 shift over correct number of places add.l d7,d1 bcc.s finnr no need to check for overflow ************************************************** * * Procedure : rndnear * * Description: Round a real number to the nearest whole real number. * If the real is too large to be rounded, the same * number addq.l #1,d0 propagate carry bra.s finnr if overflow, exponent adjusted! add0 sub.w #32,d6 get the correct mask lsl.l d6,d7 add.l d7,d0 do add - oveflow goes into mantissa * * Clear the bottom is returned. * * Author : Paul Beiser * * Revisions : 1.0 06/01/81 * * Parameters : (d0,d1) - real argument * * Registers : d5-d7 - scratch * * Result : The result is returned in (d0,d1). * * Error(s) (d5) bits of (d0,d1). * finnr moveq #-1,d7 mask for the clear cmp.w #32,d5 blt.s cleard1 branch of only have to clear bits in d1 moveq #0,d1 else clear all of d1; maybe some of d0 sub.w #32,d5 adju : None * * References : None * ******************************************************************************* rndnear move.l d0,d6 extract the exponent swap d6 place in low word and.w #$7ff0,d6 get rid of sigst count bne.s clearcon branch if more to clear rts else return clearcon lsl.l d5,d7 get mask and.l d7,d0 rts cleard1 lsl.l d5,d7 and.l d7,d1 rts page *******************************     e in the range [.5,1). This procedure is * used only in the elementary function evaluations. * * Author : Paul Beiser * * Revisions : 1.0 06/01/81 * * Parameters : (d0,d1) - real number to be augmented * * oth operands are * 64 bit floating point reals. * * Author : Paul Beiser * * Revisions : 1.0 06/01/81 * 2.0 09/01/83 For -0 as valid input * * Parameters : (d0,d1) - operand 1 *  Result : The result exponent is returned in d7. * * Error(s) : None, because all arguments are defined to be in a * restricted range. * * References : None * ********************************************************** (d2,d3) - operand 2 * * Result : Returned in the CCR (EQ,NE,GT,LT,GE,LE). * * Misc : The operands are not destroyed, and no other registers * are used. * ************************************************************************************************** * * Procedure : adx * * Description: Augment a real number's exponent. This procedure is * used only in the elementary function evaluations. * * Author : Paul Beiser********************* intxp move.l d0,d7 don't destroy the original number swap d7 place exponent into low word and.w #$7ff0,d7 lsr.w #4,d7 sub.w #1022,d7 mantissa in range [0.5,1) (ignore hidden bit) rts  * * Revisions : 1.0 06/01/81 * 1.1 11/03/83 For: * o Removing the test for 0. * * Parameters : (d0,d1) - real number to be augmented * d7 - amount to be augmented  page ******************************************************************************* * * Procedure : setxp * * Description: Set the exponent of a real number. The mantissa is * assumed to be in the range [.5,1). This proce* * Registers : d6 - scratch * * Result : The result is returned in (d0,d1). * * Error(s) : None, because all arguments are defined to be in a * restricted range. * * References : None * **********dure is * used only in the elementary function evaluations. * * Author : Paul Beiser * * Revisions : 1.0 06/01/81 * * Parameters : (d0,d1) - real number to be augmented * d7 - unbiase********************************************************************* adx swap d0 put exponent into lower part move.w d0,d6 extract old exponent and.w #$800f,d0 first, remove old exponent in the result and.w #$d value of the new exponent. * * Result : The result is returned in (d0,d1). * * Error(s) : None, because all arguments are defined to be in a * restricted range. * * References : None * *************************7ff0,d6 asl.w #4,d7 faster if don't have to shift back add.w d7,d6 new exponent computed and.w #$7ff0,d6 large exp and negative augment;negative sign or.w d6,d0 place in new exponent swap d0 ****************************************************** setxp swap d0 and.w #$800f,d0 remove the exponent add.w #1022,d7 hidden bit becomes part of exponent lsl.w #4,d7 always positive after bias add, so do lsl or.w  restore correct order rts page ******************************************************************************* * * Procedure : intxp * * Description: Extract the exponent of a real number. The mantissa is * assumed to b d7,d0 place in new exponent swap d0 re-align rts page ******************************************************************************* * * Procedure : compare * * Description: Compare operand 1 with operand 2. B      ***************************** compare tst.l d0 test first for sign of the first operand bpl.s rcomp2 tst.l d2 test sign of second operand bpl.s rcomp2 * cmp.l d0,d2 both negative so do test backward bn - real number to be evaluated * a6 - address of the coefficients * d0 - the degree of the polynomial * * Registers : d2,d3 - scratch * * Result : The result is returned in (d0,d1)e.s cmpend CCR set here cmp.l d1,d3 first part equal, check second part beq.s cmpend EQ flag set bhi.s grt unsigned compare lst move #8,CCR XNZVC = 01000 rts * rcomp2 cmp.l d2,d0. * * Error(s) : None, because all arguments are defined to be in a * restricted range. * * References : radd, rmul * * Miscel : These procedures used to be know as "horner" and * "hornera" resp at least one positive, ordinary test bne.s checkm0 must check for 0 compared with -0 cmp.l d3,d1 both must be positive beq.s cmpend bls.s lst branch if LT grt move #0,CCR XNZVC = 00000ectively. For hardware floating * point, 2 different procedures are needed: one * for the software math and one for the hardware math. * *******************************************************************************  cmpend rts * * Check for the operands being 0 and -0. * checkm0 tst.l d0 bpl.s d2minus branch if second operand is negative cmp.l #minuszero,d0 else (d0,d1) is negative bne.s finm0 reset condition code tst.l d2 soft_horner move.w d0,-(sp) save the degree of the polynomial move.l (a6)+,d0 initialize result to first coeff. move.l (a6)+,d1 horloop move.l a4,d2 get w move.l a5,d3 bsr rmul previous result * w  bne.s finm0 must check all of it rts had (d0,d1) = -0 and (d2,d3) = 0 d2minus cmp.l #minuszero,d2 (d2,d3) is negative bne.s finm0 reset condition code tst.l d0 bne.s finm0 must check all of i move.l (a6)+,d2 get next coefficient move.l (a6)+,d3 bsr radd add to previous result subq.w #1,(sp) bne.s horloop hordone addq.l #2,sp remove the degree count rts soft_hornera move.w d0,-(sp) st rts had (d2,d3) = -0 and (d0,d1) = 0 finm0 cmp.l d2,d0 else reset condition code rts page ******************************************************************************* * * Procedures : soft_horner / soft_hornera * *ave the degree of the polynomial move.l a4,d0 initialize result to w move.l a5,d1 horloopa move.l (a6)+,d2 get next coefficient; (d0,d1) ok move.l (a6)+,d3 bsr radd do the addition; (d0,d1) has result subq.w #1,( Description: Evaluate a polynomial. "soft_hornera" assumes that the * leading coefficient is 1, and thus avoids an extra * multiply. These procedures are used only in the software * versions osp) beq.s hordone move.l a4,d2 get w; (d0,d1) correct move.l a5,d3 bsr rmul (d0,d1) has result bra.s horloopa page ******************************************************************************* * * f the elementary function evaluations. These * procedures call software floating point routines. * * Author : Paul Beiser * * Revisions : 1.0 06/01/81 * 2.0 09/01/83 * * Parameters : (a4,a5)  Procedures : flpt_horner / flpt_hornera * * Description: Evaluate a polynomial. "flpt_hornera" assumes that the * leading coefficient is 1, and thus avoids an extra * multiply. These procedures are used only in      #1,d0 see if done bne.s fhorloop fhordone rts flpt_hornera movem.l a4-a5,movf_m_f5(a0) (f5,f4) <- w tst.w movl_f4_f0(a0) w is also first partial result movem.l bogus4(a0),d4-d5 bogus reads with no error flaerror page ******************************************************************************* * * Procedure : flpt_reset * * Description: Reset the floating point card, and initialize the 16081 * FPU with a rounding mode of rog fhorlopa move.l (a6)+,movf_m_f3(a0) get the next coefficient move.l (a6)+,movf_m_f2(a0) tst.w addl_f2_f0(a0) previous result + coefficient movem.l bogus4(a0),d4-d5 bogus reads with no error flag subq.w #1,d0 und-to-even and set the * underflow enable trap. * * Author : Paul Beiser * * Revisions : 1.0 09/01/83 * : 3.2 02/19/87 DRAGON support SFB * * Registers : d0,d1 - scratch * *  the * elementary function evaluation. * * Author : Paul Beiser * * Revisions : 1.0 06/01/81 * 2.0 09/01/83 For: * o Hardware floating point * * Parameters : (a4,a5) see if done beq.s fhordone tst.w mull_f4_f0(a0) else result*w movem.l bogus4(a0),d4-d5 bogus reads with no error flag bra.s fhorlopa page ***************************************************************************** - real number to be evaluated (w) * a0 - address of the floating point hardware * a6 - address of the coefficients * d0 - the degree of the polynomial * * Registers ** * * Procedure : flpt_error * * Description: Determine the type of error that has just happened in the * 16081 FPU and generate the appropriate Pascal Workstation * ESCAPECODE. * * Author : Pau : f0-f5 - scratch floating point registers * d4-d5 - results of the bogus reads * * Result : Returned in (f1,f0). * * Error(s) : All arguments are defined to be in a restricted range, * so l Beiser * * Revisions : 1.0 09/01/83 * * Registers : d0 - the 16081 FPU status register * a0 - address of the floating point card * * Result : An ESCAPE is generated. * * References : flpt_error conditions cannot arise. * * Miscel : The caller must save and restore the contents of f0-f5. * (a4,a5) is left unchanged. * ******************************************************************************* flpt_horner movcardaddr, err_overflow, err_underflow, * err_divzero, err_miscel * * Miscel : A 'miscellaneous floating point hardware error' escape * is generated for things other than underflow, overflow, * e.l (a6)+,movf_m_f1(a0) first coefficient result in (f1,f0) move.l (a6)+,movf_m_f0(a0) movem.l a4-a5,movf_m_f5(a0) (f5,f4) <- w fhorloop tst.w mull_f4_f0(a0) w * previous result movem.l bogus4(a0),d4-d5 bogus reads and get  and divide-by-zero. * ******************************************************************************* flpt_error equ * the floating point error handler moveq #flpt_extracttrap,d0 extract the TT field and.l sfsr_m_error flag move.l (a6)+,movf_m_f3(a0) get the next coefficient move.l (a6)+,movf_m_f2(a0) tst.w addl_f2_f0(a0) add coefficient to previous result movem.l bogus4(a0),d4-d5 bogus reads with no error flag subq.w m+flpt_cardaddr,d0 the floating point status register cmpi.w #flpt_under,d0 beq err_underflow cmpi.w #flpt_over,d0 beq err_overflow cmpi.w #flpt_divzero,d0 beq err_divzero bra err_miscel miscellaneous floating point !      Parameters : None * * References : flpt_cardaddr * ******************************************************************************* flpt_reset equ * lea flpt_cardaddr,a0 point to the card cmpi.b #flpt_card_id,flpt_id(a0)  store negative signed result clr.w (a0)+ and return a zero string clr.l (a0)+ clr.l (a0) rts relb_1 tst.l d0 check for zero bne.s bcd_nzer non-zero, but could still be illegal ts see if it has correct ID SFB beq is_float_card if so, continue SFB move.w #-12,SYSGLOBALS-2(a5) else escapecode:=buserror SFB trap #10 and escape(escapecode) SFB is_float_card equ * t.l d1 bne err_illnumbr clr.l (a0)+ return zero string clr.l (a0)+ clr.l (a0) rts fix this up if unpacked bcd_nzer bmi.s bcd_neg clr.w (a0)+ store positive sign resul SFB move.b #1,flpt_id(a0) enable the card move.l #flpt_initmask,lfsr_m_m(a0) UEN; RM to nearest rts page ******************************************************************************* * * Procedure t bra.s rbcd_1 bcd_neg move.w #1,(a0)+ store negative signed result bclr #31,d0 and clear sign rbcd_1 move.l d0,d4 scratch register swap d4 get exponent and.w #$7ff0,d4 mask off fraction and: relbcd * * Description: Convert a real number into a decimal string. * * Author : Paul Beiser / Ted Warren * * Revisions : 1.0 06/01/81 * 2.0 09/01/83 For: * o To check for -0 as a v sign * * Check for valid exponent. * lsr.w #4,d4 right justify beq err_illnumbr exponent too small? sub.w #1023,d4 remove bias cmp.w #1023,d4 exponent too large? bgt err_illnumbr * * Compute the estimator Ealid input * * Parameters : (d0,d1) - real argument to be converted * a0 - address of the result * d7 - number of digits wanted * * Registers : (d2,d3) - value from table *  = TRUNC(log10(2) * exponent). Computation is done * with a fixed point multiply. * move.w #$4d10,d5 log10(2) = 0.4d104... (hex) tst.w d4 check the sign of the base 2 exponent bge.s mul1 d5 as correct estimator a d4 - estimator * d5 - index into table * d6 - scratch * d7 - number of digits to return * a1 - table addresses/ local storage * * ddq.w #1,d5 negative exponents require 0.4d11 bug69 mul1 muls d5,d4 swap d4 remove fractional part of the result addq.w #1,d4 1 larger for the algorithm * move.w d4,d5 copy into d5 for table in Result : The result is returned through (a0). * * Error(s) : Invalid IEEE real numbers * * References : tb_pwtt, tb_auxpt, tb_bin, rmul, err_illnumbr * ******************************************************************************* dexing add.w #64,d5 add 64 for biasing to positive bmi.s rbcd_3 test for -64 <= E <= +64 cmp.w #128,d5 ble.s rbcd_2 branch if only one multiply necessary * * Map the number to be converted into the range (10^* * Real to bcd convert begins here. Determine sign of result. * relbcd cmp.l #minuszero,d0 check for a -0 bne.s relb_1 branch if not possible tst.l d1 must be a zero here! bne err_illnumbr move.w #1,(a0)+-64,10^64) using * an additional floating multiply. * rbcd_3 move.w d4,d5 asr.w #6,d5 estimator div 64 bpl.s div_fix1 branch if no fixup necessary addq.w #1,d5 to keep mod and div correct div_fix1 neg.w d5 !      addq.w #8,d5 adjust index to next entry bra.s bcmul so number will map into correct range * * Map the number into the range [.1,1). If the number to be converted is a * power of ten, final real result may be 1 or 2 bits leafter each multiply by 100. * real_c2 move.l d0,d6 extract exponent into d6 swap d6 lsr.w #4,d6 sub.w #1023-4,d6 compute the number of left shifts swap d0 and.w #$f,d0 or.w #$10,d0 put in hiden one swap ss than .1 because of * the rounded table entry and the inexact real multiply. This condition is * checked for and the correct BCD number is returned. * * If the number to be converted is a power of ten, the map may also produce a * value of 1. This co d0 tst.b d6 beq.s finish lpten add.l d1,d1 loop to shift (at most 4 shifts) addx.l d0,d0 subq.b #1,d6 bne.s lpten * * Extract the correct number of digits (as specified by d7). One extra digit * is returned fo form address of reciprocal addq.w #4,d5 bias to the positive asl.w #3,d5 * 8 (bytes per real) lea tb_auxpt,a1 address of 10^(N*64) table move.l 0(a1,d5.w),d2 get real from table move.l 4(a1,d5.w),d3 movea.w ndition is also checked for. * adjes subq.w #1,d4 adjust exponent estimator (reach only if lt ! ) bcmul sub.w #512,d5 find complement table entry neg.w d5 add.w #512,d5 move.l 0(a1,d5.w),d2 fetch value for conversion d4,a1 save estimator move.w d7,-(sp) save count bsr rmul do the operation move.w (sp)+,d7 restore count move.w a1,d4 restore estimator move.w d4,d5 calculate index for next operation asr.move.l 4(a1,d5.w),d3 movea.w d4,a1 estimator here to stay in a1 !! move.w d7,-(sp) save count bsr rmul do the operation move.w (sp)+,d7 restore count * * Test for the result being less than 0.1 * addq.w #1,w #6,d5 estmator div 64 bpl.s div_fix2 addq.w #1,d5 to keep mod consistent with the div div_fix2 asl.w #6,d5 calculating estimator mod 64 neg.w d5 add.w d4,d5 add.w #64,d5 bias to positive * * Na1 adjust the exponent cmp.l #$3fb99999,d0 top part of 0.1 bgt.s real_c1 branch if (d0,d1) > .1 cmp.l #$9999999a,d1 tops are = ; must check the bottom parts bcc.s real_c1 cc implies greater than or equal to umber is in appropriate range. Use estimator as an index to see * if the number is in the correct decade. If they are in the same decade, * modify the offset to point to the next larger decade so the map will work. * rbcd_2 asl.w #3,d5 conve move.l #$10000000,(a0)+ else return bcd value of .1 clr.l (a0)+ return 16 digits (faster than checking d7) move.w a1,(a0) place exp into the bcd buffer rts * * Check for the converted number being exactly rt logical index to physical lea tb_pwtt,a1 address of table move.l 0(a1,d5.w),d2 get high order entry cmp.l d2,d0 compare high order parts blt.s adjes branch if table entry will work in the map bgt.s not_adj one. * real_c1 cmp.l #$3ff00000,d0 check for (d0,d1) = 1 = (3ff00000 00000000) bne.s real_c2 branch if ok move.l #$10000000,(a0)+ else return bcd value of 1 clr.l (a0)+ return 16 digits (faster than checking d7) ad branch if must retrieve the next table entry move.l 4(a1,d5.w),d3 tops are equal; compare low order parts cmp.l d3,d1 must be unsigned compare! bcs.s adjes branch if low (if carry is set, must be low) not_adj dq.w #1,a1 boundary condition, so another adjust move.w a1,(a0) place into the bcd buffer rts * * Fix up result so that implied decimal point is after bit #23 in d0. Hence bit * numbers 24/31 will contain the 2 decimal digits "     r the purposes of rounding. * finish move.w a1,8(a0) place exponent in memory first lea tb_bin,a1 address of binary to double bcd table bgt.s fin_1 check for improper number of digits maxnum moveq #15,d7 bountb_pwt, tb_pwt4, tb_pwt8, tb_auxpt, tb_bcd * ******************************************************************************* * * Only eight digits to convert so do it fast. * bcd8 mulu #10000,d0 move.b (a0)+,d7 fetch third pair move.b dary condition bra.s lp16m get all the digits fin_1 cmp.w #16,d7 check if wants all the digits bge.s maxnum branch if set counter to maximum amount * ror.b #1,d7 determine if odd or even number wanted 0(a1,d7.w),d7 lookup binary value mulu #100,d7 multiply by 100 add.l d7,d0 and add to sum moveq #0,d7 move.b (a0)+,d7 fourth pair move.b 0(a1,d7.w),d7 lookup binary value add.l d7,d0 last add for frac bcs.s oddnum branch if odd number wanted rol.b #1,d7 even number wanted - adjust counter addq.w #1,d7 bra.s lp16m oddnum rol.b #1,d7 restore odd number of digits * lp16m move.l d0,d2 multipltion addq.l #4,a0 point at bcd exponent moveq #0,d1 shift result right 6 places move.w d0,d1 across d0,d1 pair lsr.l #6,d0 ror.l #6,d1 clr.w d1 move.l d0,d6 form index for normalizing swap d6 y by 100 by shift and add move.l d1,d3 add.l d3,d3 addx.l d2,d2 add.l d3,d3 addx.l d2,d2 add.l d3,d1 addx.l d2,d0 add.l d1,d1 addx.l d0,d0 move.l d0,d2 move.l d1,d3 add.l d3,d3 addx.l d2,d2 add.l d3,d3 addx and.w #$1e,d6 look at bits 20, 19, 18, and 17 move.w pn_tb_4(d6.w),d6 lookup shift value move.w #1023+26-1,d7 exponent value if normalized sub.w d6,d7 subtract # of shifts required neg.w d6 computed goto for no.l d2,d2 add.l d3,d1 addx.l d2,d0 add.l d1,d1 addx.l d0,d0 swap d0 extract top 8 bits for conversion move.w d0,d3 lsr.w #8,d3 and.w #$00ff,d0 remove top 8 bits from conversion product swap d0 move.b 0rmalizing addq #4,d6 asl.w #2,d6 jmp shiftr8(d6.w) shiftr8 add.l d1,d1 addx.l d0,d0 entry for shift by 4 add.l d1,d1 addx.l d0,d0 entry for shift by 3 add.l d1,d1 addx.l d0,d0 entry for shift by(a1,d3.w),(a0)+ store in result area subq.w #2,d7 and loop (2 digits per loop) bpl.s lp16m until gotten correct number of digits rts page ******************************************************************************* * *  2 add.l d1,d1 addx.l d0,d0 entry for shift by 1 asl.w #4,d7 shift exponent into position swap d7 add.l d7,d0 add to fraction, removing hidden 1 lea tb_pwt8,a1 address of table used for 8 digit conve Procedure : bcdrel * * Description: Convert a bcd number into a real number. * * Author : Paul Beiser / Ted Warren * * Revisions : 1.0 06/01/81 * * Parameters : a0 - address of the bcd number * * Registers : art bra fractsgn determine sign and finish conversion * * Table for number of normalization shifts versus value. * It must be in this location for short mode addressing. * pn_tb_4 dc.w 4,3,2,2,1,1,1,1,0,0,0,0,0,0,0,0 *********************1 - address of tables * d2-d7 - scratch * * Result : The result is returned in (d0,d1). * * Error(s) : Decimal strings too large or too small. * * References : rmul, err_impvalue * ********************************************************** * * Only four digits (8 at most) to convert so do it extremely fast. * bcd4 clr.w d0 move.b (a0)+,d0 get first two digits move.b 0(a1,d0.w),d0 lookup binary value mulu #100"     8 or less digits beq.s bcd4 move.b (a0)+,d2 fetch first bcd digit pair move.b 0(a1,d2.w),d2 lookup its binary value mulu #62500,d2 multiply by 1,000,000 asl.l #4,d2 (62,500*16) move.b (a0)+,d7 fetch second pd2 add.l d2,d1 add to previous result addx.l d4,d0 add.l d3,d1 add in conversion from lower 8 digits bcc.s bcdr_nz addq.l #1,d0 * * Use jump table for post normalization and exponent location. * bcdr_nz move.l d0,dair move.b 0(a1,d7.w),d7 lookup binary value mulu #10000,d7 multply by 10,000 add.l d7,d2 and add to sum moveq #0,d7 move.b (a0)+,d7 fetch third pair move.b 0(a1,d7.w),d7 lookup binary value mulu #100,d7 6 swap d6 get upper 16 bits of fraction and.w #$3e,d6 mask off all but top 5 bits (17-21) move.w eval_exp(d6.w),d7 look up exponent jmp pn_table(d6.w) * * Exponent value table for converted bcd integer. * 1023 (bias) ,d0 weight by 100 move.b (a0)+,d7 get second two digits move.b 0(a1,d7.w),d7 lookup binary value add.w d7,d0 tst.w (a0) four more digits? bne bcd8 branch only if 4 more digits addq.l #6,a0  multiply by 100 add.l d7,d2 and add to sum moveq #0,d7 move.b (a0)+,d7 fetch fourth pair move.b 0(a1,d7.w),d7 lookup binary value add.l d7,d2 add to sum * * Convert bottom eight bcd digits and store in d3. *  point at exponent moveq #0,d1 if four digits then low order real =0 asl.l #7,d0 shift by at least 7 to post normalize move.l d0,d6 form an index swap d6 for post normalization and.w  move.b (a0)+,d3 fetch fifth bcd digit pair move.b 0(a1,d3.w),d3 lookup its binary value mulu #62500,d3 multiply by 1,000,000 asl.l #4,d3 (62,500*16) move.b (a0)+,d7 fetch sixth pair move.b 0(a1,d7.w),d7 look #$1e,d6 look at bits 20,19,18, and 17 move.w pn_tb_4(d6.w),d6 lookup shift value asl.l d6,d0 normalize real move.w #1023+13-1,d7 form exponent sub.w d6,d7 subtract amount normalized asl.w #4,d7 up binary value mulu #10000,d7 multply by 10,000 add.l d7,d3 and add to sum moveq #0,d7 move.b (a0)+,d7 fetch seventh pair move.b 0(a1,d7.w),d7 lookup binary value mulu #100,d7 multiply by 100 add.l d align into position swap d7 add.l d7,d0 merge into fraction lea tb_pwt4,a1 address of table for 4 digit convert bra fractsgn ****************************************************************************7,d3 and add to sum moveq #0,d7 move.b (a0)+,d7 fetch eighth pair move.b 0(a1,d7.w),d7 lookup binary value add.l d7,d3 add to sum * * Multiply high order part by 1,000,000 and add low order part * 1,000,000=$5f5e100*** * * BCD to real conversion begins here. * bcdrel addq.l #2,a0 skip over sign * * Convert first eight bcd digits to binary and store in d2. * tst.b (a0) check for zero (remember, must be normalized!) bne.s continue . Result=(((hi * 5f5e) * $1000) + (hi * $100)) + lo. * moveq #0,d4 move.w d2,d1 mulu #$5f5e,d1 hi.word(lower) * 5f5e move.l d2,d0 swap d0 mulu #$5f5e,d0 hi.word(upper) * 5f5e swap d1 move.w d1,d4 clr.w d1 adcontinue if non-zero moveq #0,d0 else return a value of 0 move.l d0,d1 rts continue lea tb_bcd,a1 address of 2 digit bcd to binary table moveq #0,d3 moveq #0,d7 moveq #0,d2 tst.l 4(a0) check for d.l d4,d0 move.w d0,d4 lsr.l #4,d0 multiply by $1000 by shifting lsr.l #4,d1 ror.l #4,d4 clr.w d4 or.l d4,d1 move.l d2,d4 clr.w d4 swap d4 lsr.w #8,d4 multiply hi by $100 by shifting lsl.l #8,#     + 52 (size of integer) - #postnorm shifts * -1 (gets rid of hidden one) all times 16 to bit align. * eval_exp dc.w 17120 dc.w 17136 dc.w 17152 dc.w 17152 dc.w 17168 dc.w 17168 dc.w 17168 dc.w 17168 dc.w 17184,171p.w #128,d6 E>64? bgt.s bcdr_3 must do 2 multiplies, return here later bcdr_4 asl.w #3,d6 convert logical to physical index move.l 0(a1,d6.w),d2 lookup values move.l 4(a1,d6.w),d3 move.l sysglobals84,17184,17184 dc.w 17184,17184,17184,17184 dc.w 17200,17200,17200,17200 dc.w 17200,17200,17200,17200 dc.w 17200,17200,17200,17200 dc.w 17200,17200,17200,17200 pn_table bra.s pn_4 bra.s pn_3 bra.s pn_2 bra.s pn_2 br-10(a5),-(sp) TRY, could get over or underflow pea improper address for the possible ESCAPE move.l sp,sysglobals-10(a5) bsr rmul do the operation addq.l #4,sp remove ESCAPE address a.s pn_1 bra.s pn_1 bra.s pn_1 bra.s pn_1 bra.s pn_0 bra.s pn_0 bra.s pn_0 bra.s pn_0 bra.s pn_0 bra.s pn_0 bra.s pn_0 bra.s pn_0 bra.s pn_m1 bra.s pn_m1 bra.s pn_m1 bra.s pn_m1 bra.s pn_m1 move.l (sp)+,sysglobals-10(a5) restore old TRY block rts * * Exponent > abs(64). * bcdr_3 move.w d3,-(sp) save exponent for later asr.w #6,d3 div 64 bpl.s divfix1 this is Paul Beiser's patented DIV addq.w #1 bra.s pn_m1 bra.s pn_m1 bra.s pn_m1 bra.s pn_m1 bra.s pn_m1 bra.s pn_m1 bra.s pn_m1 bra.s pn_m1 bra.s pn_m1 bra.s pn_m1 nop must be there; can't branch to next instruction! * pn_m1 lsr.l #1,,d3 divfix1 addq.w #4,d3 bias to the positive asl.w #3,d3 change logical to physical index lea tb_auxpt,a0 address of secondary table move.l 0(a0,d3.w),d2 move.l 4(a0,d3.w),d3 fetch value bsr rmul d0 16 digit bcd number was too large roxr.l #1,d1 and so overflowed requiring a shift bra.s pn_done to the right and dumping of one bit * pn_4 add.l d1,d1 addx.l d0,d0 pn_3 add.l d1,d1 addx.l d0,d0 pn_2 do the operation move.w (sp)+,d6 restore exponent move.w d6,d3 find exponent mod 64 asr.w #6,d3 bpl.s divfix2 thank you Paul addq.w #1,d3 divfix2 asl.w #6,d3 sub.w d3,d6 add.w #64,d6 bias to the  add.l d1,d1 addx.l d0,d0 pn_1 add.l d1,d1 addx.l d0,d0 pn_0 equ * pn_done swap d7 insert exponent add.l d7,d0 automatically removes hidden one lea tb_pwt,a1 address of primary powers of ten tabpositive bra bcdr_4 one more multiply to do * * Either real multiply generated an ESCAPE or error detected earlier. * Generate the ESCAPE with the correct error code. * improper move.l (sp)+,sysglobals-10(a5) restore old TRY block brale * * Check sign of bcd number. * fractsgn tst.w -10(a0) test bcd sign beq.s firfl bset #31,d0 set sign bit if negative * * Fetch exponent, and test for proper range. * firfl move.w (a0),d3 get binary exponent c err_impvalue improper value error page ******************************************************************************* * * Procedure : flpt_sin / flpt_cos * * Description: Compute the sine/cosine of the numeric item on themp.w #-309,d3 blt err_impvalue number too small cmp.w #309,d3 bgt err_impvalue number too large * * Check for one or two multiplies. * move.w d3,d6 add.w #64,d6 bias to the positive bmi.s bcdr_3 E<-64? cm * top of the stack (radians mode). This algorithm is taken * from the book "Software Manual for the Elementary * Functions" by William Cody and William Waite. * * Author : Paul Beiser * * #     0) make (f1,f0) positive movem.l bogus4(a0),d4-d5 wait for the chip to finish f@sincs9 tst.w movl_f0_f2(a0) (f2,f3) <- abs(x) = y movem.l bogus4(a0),d4-d5 wait for the chip to finish bra.s f@sincos (f1,f0 else set result to 0 move.l #0,movf_m_f4(a0) and continue f@sin34 move.l movf_f5_m(a0),d0 get the result move.l movf_f4_m(a0),d1 bsr rellnt convert to a 32 bit integer move.w d0,d7 scratch) <- abs(x) * * Entry point for the cosine routine. * flpt_cos move.l 4(sp),d0 get x move.l 8(sp),d1 lea flpt_cardaddr,a0 point to the start of the hardware movem.l a5-a6,-(sp) save dedicated registers moveq  register lsr.w #1,d7 determine if even or odd bcc.s f@step8 branch if even neg.w (sp) sgn <- -sgn f@step8 move.l d0,movil_m_f4(a0) (f5,f4) <- xn (converted d0 to real) movem.l bogus Revisions : 1.0 06/01/81 * 2.0 09/01/83 For: * o Hardware floating point * o To check for -0 as a valid input * * Parameters : 4(sp) - real argument * * Reg#1,d3 can't move immediate to A register movea.w d3,a1 set flag for in the cos routine move.l d1,movf_m_f0(a0) (f0,f1) <- x move.l d0,movf_m_f1(a0) bne.s f@cos_1 if non-zero continue f@cosristers : a1 - flag for either sin/cos * a0 - address of the floating point card * -(sp) - sign of the result * d4,d5 - results of the bogus reads * * Result : Retet1 move.l #$3ff00000,d0 else return 1 as the result moveq #0,d1 bra f@done (d0,d1) <- 1; f@cos_1 cmp.l #minuszero,d0 check for a -0 beq.s f@cosret1 move.w #1,-(sp) set sgn flag turned on the top of the stack. * * Error(s) : An argument too large in magnitude returns an error. * * References : flpt_horner, compare, cff_sin, flpt_cardaddr, rellnt * err_trigerr * **************************************o one tst.w absl_f0_f0(a0) (f1,f0) <- abs(x) movem.l bogus4(a0),d4-d5 move.l #$3ff921fb,movf_m_f3(a0) pi/2 move.l #$54442d18,movf_m_f2(a0) tst.w addl_f0_f2(a0) (f2,f3) <- y = abs(x) + pi/2 movem.l bogus4(a0),d4-d5 * * ***************************************** flpt_sin move.l 4(sp),d0 get x move.l 8(sp),d1 lea flpt_cardaddr,a0 point to the start of the hardware movem.l a5-a6,-(sp) save dedicated registers suba.w a1,a1 Common point for both the sine and cosine routines. * (f1,f0) <- abs(x), (f3,f2) <- y * f@sincos move.l movf_f3_m(a0),d0 get y move.l movf_f2_m(a0),d1 move.l #$41b1c583,d2 check argument not too large move.l #$1a000000,d3  set flag for in the sin routine move.l d1,movf_m_f0(a0) (f1,f0) <- x move.l d0,movf_m_f1(a0) bmi.s f@step2neg branch if set sgn flag to negative move.w #1,-(sp) set sgn flag to positive bra.s  ymax = int(pi*2^(53/2)) bsr compare bge err_trigerr branch if y >= ymax * * Argument in range. Compute n and xn. Note that underflow is possible here * if y is real small. * move.l #$3fd45f30,movf_m_f5(a0) compute y * 1/pi  f@sincs9 f@step2neg move.w #-1,-(sp) sgn flag negative cmp.l #minuszero,d0 check for a -0 bne.s stx@3 branch if not a -0 move.w #1,(sp) else change sign to + stx@3 tst.w absl_f0_f0(amove.l #$6dc9c883,movf_m_f4(a0) tst.w mull_f2_f4(a0) (f5,f4) <- y*1/pi movem.l bogus4(a0),d4-d5 btst #q,status(a0) see if had underflow beq f@sin34 continue if no underflow move.l #0,movf_m_f5(a0) $     4(a0),d4-d5 * * See if adjustment necessary to xn. At this stage, * (f1,f0) <- abs(x), (f3,f2) <- y, and (f5,f4) <- xn. * move.w a1,d6 for the check beq.s f@step10 branch if sin wanted move.l #$bfe00000,movf_m_ (f6,f7) <- f (untouched by horner) movem.l bogus4(a0),d4-d5 bsr flpt_horner compute p(g); result in (f1,f0) movem.l a4-a5,movf_m_f3(a0) restore g tst.w mull_f0_f2(a0) (f3,f2) <- g*p(g) movem.l bogus4(a0),d4-d5 f7(a0) else adjust xn move.l #0,movf_m_f6(a0) by -1/2 tst.w addl_f6_f4(a0) (f5,f4) <- xn = xn - 0.5 movem.l bogus4(a0),d4-d5 * * Compute the reduced argument f. * f@step10 move.l #$c0092200,movf_m_f7(a0) get constant  tst.w mull_f6_f2(a0) (f3,f2) <- f*g*p(g) movem.l bogus4(a0),d4-d5 tst.w addl_f2_f6(a0) (f6,f7) <- f + f*g*p(g) movem.l bogus4(a0),d4-d5 move.l movf_f7_m(a0),d0 (d0,d1) <- result move.l movf_f6_m(a0),d1 * f@sign_tst t-c1 move.l #0,movf_m_f6(a0) (f7,f6) <- -c1 tst.w mull_f4_f6(a0) (f7,f6) <- -xn*c1 movem.l bogus4(a0),d4-d5 tst.w addl_f6_f0(a0) (f0,f1) <- abs(x) - xn*c1 movem.l bogus4(a0),d4-d5 move.l #$3ee2aeef,movf_m_f7(a0) (f7,fst.w (sp)+ retrieve sgn bpl.s f@done branch if positive sign bchg #31,d0 else result <- result * sgn * * Place result on the stack and return. * f@done movem.l (sp)+,a5-a6 restore dedicated registers move.l d06) <- c2 move.l #$4b9ee59e,movf_m_f6(a0) tst.w mull_f6_f4(a0) (f5,f4) <- xn*c2 movem.l bogus4(a0),d4-d5 tst.w addl_f4_f0(a0) (f1,f0) <- f = (abs(x) - xn*c1) + xn*c2 movem.l bogus4(a0),d4-d5 * * Check size of reduced argument,4(sp) place on the stack move.l d1,8(sp) rts page ******************************************************************************* * * Procedure : soft_sin / soft_cos * * Description: Compute the sine/cosine of the numeric item o. If too small, return f as result else * compute g and continue. At this point, (f1,f0) <- f. * move.l movf_f1_m(a0),d0 get f move.l movf_f0_m(a0),d1 move.l d0,d6 save the top part of f bclr #31,d0 absn the * top of the stack (radians mode). This algorithm is taken * from the book "Software Manual for the Elementary * Functions" by William Cody and William Waite. * * Author : Paul Beiser(f) move.l #$3e46a09e,d2 2^(-53/2) move.l #$667f3bcd,d3 bsr compare bge.s f@step12 branch if f not too small move.l d6,d0 else return f as the answer bra.s f@sign_tst check fo * * Revisions : 1.0 06/01/81 * 2.0 09/01/83 For: * o To check for -0 as a valid input * o Calls to software floating point * * Parameters : 4(sp) - real argumentr the correct sign f@step12 tst.w movl_f0_f2(a0) (f3,f2) <- f movem.l bogus4(a0),d4-d5 tst.w mull_f2_f2(a0) g <- f*f movem.l bogus4(a0),d4-d5 * * Compute f + f*g*p(g), and then use sgn to determine sign of result. At * this poi * * Registers : See text of the code. * * Result : Returned on the top of the stack. * * Error(s) : An argument too large in magnitude returns an error. * * References : radd, rmul, soft_horner, err_trigerr * nt, (f1,f0) <- f and (f3,f2) <- g. * movea.l movf_f3_m(a0),a4 number to be evaluated g movea.l movf_f2_m(a0),a5 lea cff_sin,a6 point to coefficients moveq #7,d0 degree of polynomial tst.w movl_f0_f6(a0)  compare, lntrel, rellnt, cff_sin, sysglobals * ******************************************************************************* soft_sin move.l 8(sp),d1 move.l 4(sp),d0 movem.l a5-a6,-(sp) save dedicated registers bmi.s step2neg bran$     9c883,d3 move.l sysglobals-10(a5),-(sp) pea recover in case of underflow move.l sp,sysglobals-10(a5) new try block bsr rmul addq.l #4,sp remove error address move.l (sp)+,sysglobals-10(a5) rest7f3bcd,d3 bsr compare bge.s step12 branch if f not too small move.l a0,d0 else return f as the answer bra.s sign_tst still must check for the correct sign step12 move.l a0,d0 restore top part of f ore old TRY block bsr rellnt round result to a 32 bit integer move.w d0,d7 scratch register lsr.w #1,d7 determine if even or odd bcc.s step8 branch if even neg.w (sp) sgn <- -sgn step8  move.l d0,d2 move.l d1,d3 bsr rmul g <- f*f * * Compute f + f*g*p(g), and then use sgn to determine sign of result. * movea.l d0,a4 number to be evaluated movea.l d1,a5 lea cff_sin,a6 point to coefficients moch if set sgn flag to negative move.w #1,-(sp) set sgn flag to positive movea.l d0,a0 (a0,a1) <- x movea.l d1,a1 bra.s sincos common point for both routines step2neg move.w #-1,-(sp) sgn flag negative c bsr lntrel (d0,d1) <- xn movea.l a2,a4 (a4,a5) <- y movea.l a3,a5 movea.l d0,a2 (a2,a3) <- xn movea.l d1,a3 * * See if adjustment necessary to xn. * move.l a0,d0 retrieve abs(x) move.l a1,d1 move.l mp.l #minuszero,d0 check for a -0 bne.s sty@3 branch if not a -0 move.w #1,(sp) else change sign to + sty@3 bclr #31,d0 movea.l d0,a0 (a0,a1) <- abs(x) movea.l d1,a1 bra.s sincos * * Entry point for the a4,d2 retrieve y move.l a5,d3 bsr compare check abs(x) = y beq.s step10a branch if sin wanted move.l a2,d0 else adjust xn move.l a3,d1 move.l #$bfe00000,d2 -1/2 moveq #0,d3 bsr cosine routine. * soft_cos move.l 8(sp),d1 move.l 4(sp),d0 movem.l a5-a6,-(sp) save dedicated registers bne.s cos_1 if non-zero continue cosret1 move.l #$3ff00000,d0 else return 1 as the result moveq #0,d1 bra don radd xn <- xn - 0.5 movea.l d0,a2 (a2,a3) <- xn movea.l d1,a3 bra.s step10 step10a move.l a2,d0 load up (d0,d1) with xn move.l a3,d1 * * Compute the reduced argument f. * step10 move.l #$c0092200,d2 ge (d0,d1) <- 1; cos_1 cmp.l #minuszero,d0 check for -0 beq.s cosret1 move.w #1,-(sp) set sgn flag to one bclr #31,d0 abs(x) movea.l d0,a0 (a0,a1) <- abs(x) movea.l d1,a1 move.l #$3ff921fb,d2 pi/2 et constant -c1 moveq #0,d3 (d0,d1) already has xn bsr rmul -xn*c1 move.l a0,d2 get abs(x) move.l a1,d3 bsr radd abs(x) - xn*c1 movea.l d0,a0 save in (a0,a1) movea.l d1,a1 abmove.l #$54442d18,d3 bsr radd y = abs(x) + pi/2 * * Common point for both the sine and cosine routines. * sincos movea.l d0,a2 (a2,a3) <- y movea.l d1,a3 move.l #$41b1c583,d2 check argument not too large move.l #$1a000s(x) no longer needed move.l a2,d0 get xn move.l a3,d1 move.l #$3ee2aeef,d2 c2 move.l #$4b9ee59e,d3 bsr rmul xn*c2 move.l a0,d2 retrieve intermediate result move.l a1,d3 bsr radd (abs(x) 000,d3 ymax = int(pi*2^(53/2)) bsr compare bge err_trigerr branch if y >= ymax * * Argument in range. Compute n and xn. Note that underflow is possible here * if y is real small. * move.l #$3fd45f30,d2 compute y * 1/pi move.l #$6dc- xn*c1) + xn*c2 movea.l d0,a0 (a0,a1) <- f movea.l d1,a1 * * Check size of reduced argument. If too small, return * f as result else compute g and continue. * bclr #31,d0 abs(f) move.l #$3e46a09e,d2 2^(-53/2) move.l #$66%     veq #7,d0 degree of polynomial bsr soft_horner compute p(g) move.l a4,d2 retrieve g move.l a5,d3 bsr rmul g*p(g) move.l a0,d2 retrieve f move.l a1,d3 bsr rmul f*g*p(g) moveow * ******************************************************************************* flpt_exp move.l 4(sp),d0 get the operand move.l 8(sp),d1 lea flpt_cardaddr,a0 point to the start of the hardware movem.l a5-a6,-(sp) .l a0,d2 retrieve f again move.l a1,d3 bsr radd f + f*g*p(g) * sign_tst tst.w (sp)+ retrieve sgn bpl.s done branch if positive sign bchg #31,d0 else result <- result * sgn * * Place res save dedicated Pascal registers move.l #$40862e42,d2 compare against the largest move.l #$fefa39ee,d3 number < ln(maximum machine number) bsr compare bgt err_overflow overflow move.l #$c086232b,d2 ult on the stack and return. * done movem.l (sp)+,a5-a6 restore dedicated registers move.l d0,4(sp) place on the stack move.l d1,8(sp) rts * * Argument reduction caused an underflow error, so the sine routine * must have been called compare against the smallest move.l #$dd7abcd1,d3 number > ln(minimum machine number) bsr compare blt err_underflow underflow * * Test for operand so small that 1.0 is the result. * move.l d0,d6 sa. Therefore, return the original argument as the * result. * recover move.l (sp)+,sysglobals-10(a5) restore old TRY block move.l a0,d0 get original argument move.l a1,d1 bra.s sign_tst determine the sign of original argument ve top part of operand for later bclr #31,d0 get the absolute value of the operand move.l #$3c900000,d2 threshold for answer = to 1 moveq #0,d3 bsr compare bge.s f@exp_11 branch if operand in ran page ******************************************************************************* * * Procedure : flpt_exp * * Description: Compute the exponential of the numeric item on the * top of the stack. This algorithm is taken ge move.l #$3ff00000,d0 else return answer of 1.0 moveq #0,d1 bra f@donee1 place on stack and return * * Proceed with step 6 - calculate xn. * f@exp_11 move.l d6,d0 restore top part of operand* from the book "Software Manual for the Elementary * Functions" by William Cody and William Waite. * * Author : Paul Beiser * * Revisions : 1.0 06/01/81 * 2.0 09/01/83 For: *  movem.l d0-d1,movf_m_f1(a0) (f0,f1) <- x move.l #$3ff71547,movf_m_f3(a0) (f2,f3) <- 1/ln(2) move.l #$652b82fe,movf_m_f2(a0) tst.w mull_f0_f2(a0) (f2,f3) <- x * 1/ln(2) movem.l bogus4(a0),d4-d5 wait for the chip to finish  o Hardware floating point * * Parameters : 4(sp) - real argument * * Registers : a0 - address of the floating point card * d4,d5 - results of the bogus reads * * Result : R move.l movf_f3_m(a0),d0 retrieve x * 1/ln(2) move.l movf_f2_m(a0),d1 bsr rndnear (d0,d1) <- xn (conversion to int later) movem.l d0-d1,movf_m_f3(a0) (f2,f3) <- xn * * Determine g. Have (f0,f1) <- x and (f2,f3) <- xn. * eturned on the top of the stack. * * Error(s) : An argument too large or too small returns an error. * * References : flpt_horner, rndnear, rellnt, adx, cff_expp, cff_expq * compare, flpt_cardaddr, err_overflow, err_underfl move.l #$bfe63000,movf_m_f5(a0) -0.543 octal = c1 move.l #0,movf_m_f4(a0) tst.w mull_f2_f4(a0) (f4,f5) <- xn*c1 movem.l bogus4(a0),d4-d5 tst.w addl_f4_f0(a0) (f0,f1) <- x + xn*c1 movem.l bogus4(a0),d4-d5 move.l #$3f2bd%     , and finish computation. * move.l a3,d1 retrieve xn move.l a2,d0 bsr rellnt 32 bit integer (already been rounded) addq.l #1,d0 part of step 9 in the algorithm move.l d0,d7  ln(minimum machine number) bsr compare blt err_underflow * * Test for operand so small that 1.0 is the result. * move.l d0,d6 save top part of operand for later bclr #31,d0 get the absolute value of the operand move augment with r to form result move.l movf_f1_m(a0),d0 retrieve r(g) from the chip move.l movf_f0_m(a0),d1 bsr adx r(g) and n form the result * * Place result on the stack. * f@donee1 movem.l (sp)+,a5-a6 re.l #$3c900000,d2 threshold for answer = to 1 moveq #0,d3 bsr compare bge.s exp_11 branch if operand in range move.l #$3ff00000,d0 else return answer of 1.0 moveq #0,d1 bra donee1 place on stack and ret010,movf_m_f5(a0) (f4,f5) <- c2 move.l #$5c610ca8,movf_m_f4(a0) tst.w mull_f2_f4(a0) (f4,f5) <- xn*c2 movem.l bogus4(a0),d4-d5 tst.w addl_f4_f0(a0) (f0,f1) <- (x + xn*c1) + xn*c2 = g movem.l bogus4(a0),d4-d5 * * Have (f2,f3)store Pascal dedicated registers move.l d0,4(sp) move.l d1,8(sp) rts page ******************************************************************************* * * Procedure : soft_exp * * Description: Compute the exponential of the numeri <- xn and (f0,f1) <- g. * Save xn in (a2,a3) and compute z, p(z), and g*p(z), and q(z). * movea.l movf_f2_m(a0),a3 xn is not needed till much later movea.l movf_f3_m(a0),a2 tst.w movl_f0_f6(a0) (f6,f7) <- g (untouched by horner) mc item on the * top of the stack. This algorithm is taken * from the book "Software Manual for the Elementary * Functions" by William Cody and William Waite. * * Author : Paul Beiser * * ovem.l bogus4(a0),d4-d5 tst.w mull_f0_f0(a0) (f0,f1) <- g*g = z movem.l bogus4(a0),d4-d5 movea.l movf_f0_m(a0),a5 (a4,a5) <- z movea.l movf_f1_m(a0),a4 lea cff_expp,a6 point to coefficients moveq #2,d0  Revisions : 1.0 06/01/81 * 2.0 09/01/83 For: * o Calls to software floating point * * Parameters : 4(sp) - real argument * * Registers : See text of the code. * * Result : Re degree of p bsr flpt_horner compute p(z); result in (f0,f1) tst.w mull_f0_f6(a0) (f6,f7) <- g * p(z) movem.l bogus4(a0),d4-d5 lea cff_expq,a6 point to coefficients moveq #3,d0 degturned on the top of the stack. * * Error(s) : An argument too large or too small returns an error. * * References : radd, rmul, rdvd, soft_horner, * compare, rndnear, rellnt, adx, cff_expp, cff_expq * erree of q bsr flpt_horner do the evaluation; (a4,a5) still has z * * Have (f0,f1) <- q(z) and (f6,f7) <- g*p(z). Compute r(g). * tst.w subl_f6_f0(a0) (f0,f1) <- q(z) - g*p(z) movem.l bogus4(a0),d4-d5 tst.w divl_f0_f6(a0) r_overflow, err_underflow * ******************************************************************************* soft_exp move.l 4(sp),d0 move.l 8(sp),d1 movem.l a5-a6,-(sp) save dedicated Pascal registers move.l #$40862e42,d2 comp (f6,f7) <- g*p(z) / (q(z) - g*p(g)) movem.l bogus4(a0),d4-d5 move.l #$3fe00000,movf_m_f1(a0) (f0,f1) <- 1/2 move.l #0,movf_m_f0(a0) tst.w addl_f6_f0(a0) (f0,f1) <- r(g) movem.l bogus4(a0),d4-d5 * * Compute integer value of xnare against the largest move.l #$fefa39ee,d3 number < ln(maximum machine number) bsr compare bgt err_overflow overflow move.l #$c086232b,d2 compare against the smallest move.l #$dd7abcd1,d3 number >&     urn * * Proceed with step 6 - calculate xn. * exp_11 move.l d6,d0 restore top part of operand and continue movea.l d0,a0 (a0,a1) <- x movea.l d1,a1 move.l #$3ff71547,d2 1/ln(2) move.l #$652b82fe,d3 bsr rmul 0,d3 bsr radd (d0,d1) <- r(g) * * Compute integer value of xn, and finish computation. * movea.l d0,a0 save r(g) movea.l d1,a1 move.l a2,d0 retrieve xn move.l a3,d1 bsr rellnt 32 bit integer (alrea(d0,d1) <- x * 1/ln(2) bsr rndnear (d0,d1) <- xn (conversion to integer later) movea.l d0,a2 (a2,a3) <- xn movea.l d1,a3 * * Determine g. * move.l #$bfe63000,d2 -0.543 octal = c1 moveq #0,d3 bsr rmul xn*c1dy been rounded) addq.l #1,d0 part of step 9 in the algorithm move.l d0,d7 augment with r to form result move.l a0,d0 (d0,d1) <- r(g) move.l a1,d1 bsr adx r and n form the result * * Place result on  move.l a0,d2 (d2,d3) <- x move.l a1,d3 (a0,a1) is now freed bsr radd x + xn*c1 movea.l d0,a0 (a0,a1) <- x + xn*c1 movea.l d1,a1 move.l a2,d0 (d0,d1) <- xn move.l a3,d1 move.l #$3f2bd01the stack. * donee1 movem.l (sp)+,a5-a6 restore dedicated registers move.l d1,8(sp) move.l d0,4(sp) rts page ******************************************************************************* * * Procedure : flpt_ln * * Description0,d2 get c2 move.l #$5c610ca8,d3 bsr rmul (d0,d1) <- xn*c2 move.l a0,d2 get previous intermediate result move.l a1,d3 bsr radd (d0,d1) <- (x + xn*c1) + xn*c2 * * Compute z, p(z), and g*p(z), and q(z). * : Compute the natural logarithm of the numeric item on the * top of the stack. This algorithm is taken * from the book "Software Manual for the Elementary * Functions" by William Cody and William Wai movea.l d0,a0 save away g movea.l d1,a1 move.l d0,d2 compute z = g*g move.l d1,d3 bsr rmul (d0,d1) <- z movem.l d0-d1,-(sp) save z away * movea.l d0,a4 compute p(z) movea.l d1,a5 lea cff_exte. * * Author : Paul Beiser * * Revisions : 1.0 06/01/81 * 2.0 09/01/83 For: * o Hardware floating point * * Parameters : 4(sp) - real argument * * Registers : a0 pp,a6 point to coefficients moveq #2,d0 degree of p bsr soft_horner do the evaluation move.l a0,d2 restore g move.l a1,d3 bsr rmul g*p(z) movea.l d0,a0 (a0,a1) <- g*p(z) movea.l d1,a1 * - address of the floating point card * d7 - exponent of the argument * d4,d5 - results of the bogus reads * * Result : Returned on the top of the stack. * * Error(s) : An argument <= 0 re movem.l (sp)+,a4-a5 restore z lea cff_expq,a6 point to coefficients moveq #3,d0 degree of q bsr soft_horner do the evaluation * * Compute r(g). * move.l a0,d2 (d2,d3) <- g*p(z) move.l a1,d3 bsr rsbt turns an error. * * References : cff_expp, cff_expq, flpt_horner, flpt_hornera, * flpt_cardaddr, intxp, setxp, err_logerr * ******************************************************************************* flpt_ln move.l 4(sp),d0  (d0,d1) <- q(z) - g*p(z) move.l d0,d2 to be used as divisor move.l d1,d3 move.l a0,d0 (d0,d1) <- g*p(z) move.l a1,d1 bsr rdvd (d0,d1) <- g*p(z) / (q(z)-g*p(z)) move.l #$3fe00000,d2 add 1/2 moveq # ble err_logerr branch if less than or = to zero move.l 8(sp),d1 * * Continue with the natural logarithm. * lea flpt_cardaddr,a0 point to the start of the hardware movem.l a5-a6,-(sp) save Pascal dedicated regi&     ,f1) <- znum - 0.5 movem.l bogus4(a0),d4-d5 wait for the chip to finish movem.l a2-a3,movf_m_f5(a0) (f4,f5) <- f tst.w mull_f2_f4(a0) (f4,f5) <- f * 0.5 movem.l bogus4(a0),d4-d5 tst.w addl_f4_f2(a0) (f2,f3) <- 0.5 + f<- xn movem.l bogus4(a0),d4-d5 move.l #$bf2bd010,movf_m_f5(a0) (f4,f5) <- c2 move.l #$5c610ca8,movf_m_f4(a0) tst.w mull_f2_f4(a0) (f4,f5) <- xn * c2 movem.l bogus4(a0),d4-d5 tst.w addl_f4_f0(a0) (f0,f1) <- xn * c2 + R(z)  * 0.5 movem.l bogus4(a0),d4-d5 * * Step 11. Have (f0,f1) <- znum and (f2,f3) <- zden. First compute z and w. * f@step11 tst.w divl_f2_f0(a0) (f0,f1) <- znum / zden = z movem.l bogus4(a0),d4-d5 tst.w movl_f0_f2(a0) (f2,f3) <- z  movem.l bogus4(a0),d4-d5 move.l #$3fe63000,movf_m_f5(a0) (f4,f5) <- c1 move.l #0,movf_m_f4(a0) tst.w mull_f4_f2(a0) (f2,f3) <- xn * c1 movem.l bogus4(a0),d4-d5 tst.w addl_f2_f0(a0) (f0,f1) <- xn*c2+R(z) + xn*c1 movem.l bosters bsr intxp extract exponent; operand in (d0,d1) movea.w d7,a1 place exponent temporarily into a1 clr.w d7 map number into range [0.5,1) bsr setxp compute value of movem.l bogus4(a0),d4-d5 tst.w mull_f2_f2(a0) (f2,f3) <- z * z = w movem.l bogus4(a0),d4-d5 * * Evaluate A(w) and store the result in (a2,a3). * tst.w movl_f0_f6(a0) (f6,f7) <- z (untouched by horner(a)) movem.l bogus4(a0),d f move.w a1,d7 save exponent in d7 movea.l d0,a2 save f in (a2,a3) movea.l d1,a3 move.l #$bfe00000,d2 combine f - 0.5 of step 9 and 10 moveq #0,d3 movem.l d0-d3,movf_m_f3(a0) (f0,f1) <- -0.5; 4-d5 movea.l movf_f3_m(a0),a4 (a4,a5) <- w movea.l movf_f2_m(a0),a5 lea cff_loga,a6 address of the coefficients moveq #2,d0 degree of the polynomial bsr flpt_horner do the polynomial evaluati(f2,f3) <- f tst.w addl_f2_f0(a0) (f0,f1) <- f - 0.5 = znum movem.l bogus4(a0),d4-d5 move.l #$3fe00000,d0 (d0,d1) <- 0.5 moveq #0,d1 * * Compare f against sqrt(1/2) to determine the correct branch. * cmpa.l #$3fe6a09e,a2 on movea.l movf_f1_m(a0),a2 (a2,a3) <- A(w) movea.l movf_f0_m(a0),a3 * * Evaluate B(w), with the result in (f0,f1). * lea cff_logb,a6 address of the coefficients moveq #3,d0 degree of the polynomial bsr  upper part of constant sqrt(1/2) bgt.s f@stepp10 blt.s f@step9 cmpa.l #$667f3bcd,a3 bhi.s f@stepp10 f@step9 movem.l d0-d1,movf_m_f3(a0) (f2,f3) <- 0.5 tst.w movl_f2_f4(a0) (f4,f5) <- 0.5 movem.l b flpt_hornera remember, (a4,a5) still has w! * * Evaluate R(z) = z + z * (w * A(w)/B(w)). Remember that (f6,f7) <- z, * (a4,a5) <- w, (a2,a3) <- A(w), and (f0,f1) <- B(w). * movem.l a2-a3,movf_m_f3(a0) (f2,f3) <- A(w) tst.w divl_f0_f2ogus4(a0),d4-d5 wait for the chip to finish tst.w mull_f0_f2(a0) (f2,f3) <- znum * 0.5 movem.l bogus4(a0),d4-d5 tst.w addl_f4_f2(a0) (f2,f3) <- znum * 0.5 + 0.5 movem.l bogus4(a0),d4-d5 subq.w #1,d7(a0) (f2,f3) <- A(w)/B(w) movem.l bogus4(a0),d4-d5 movem.l a4-a5,movf_m_f1(a0) (f0,f1) <- w tst.w mull_f2_f0(a0) (f0,f1) <- w*A(w)/B(w) movem.l bogus4(a0),d4-d5 tst.w mull_f6_f0(a0) (f0,f1) <- z*w*A(w)/B(w) movem. don't forget to adjust exponent! bra.s f@step11 (f2,f3) equals zden * * Step 10. Adjust znum and compute zden. * f@stepp10 movem.l d0-d1,movf_m_f3(a0) first, subtract 0.5 from znum tst.w subl_f2_f0(a0) (f0l bogus4(a0),d4-d5 tst.w addl_f6_f0(a0) (f0,f1) <- z + z*w*A(w)*B(w) = R(z) movem.l bogus4(a0),d4-d5 * * Finish the computation. * ext.l d7 extend the exponent of the argument move.l d7,movil_m_f2(a0) (f2,f3) '     gus4(a0),d4-d5 * * Place result on the stack and return. * move.l movf_f1_m(a0),d0 retrieve the result move.l movf_f0_m(a0),d1 movem.l (sp)+,a5-a6 restore Pascal dedicated registers move.l d0,4(sp) get the result  blt.s step9 cmpa.l #$667f3bcd,a1 bhi.s stepp10 step9 movea.l d0,a2 save away znum in (a2,a3) movea.l d1,a3 moveq #-1,d7 zden <-- znum * 0.5 + 0.5 bsr adx znum * 0.5  move.l d1,8(sp) rts page ******************************************************************************* * * Procedure : soft_ln * * Description: Compute the natural logarithm of the numeric item on the * top of the s move.l #$3fe00000,d2 add the 0.5 moveq #0,d3 bsr radd subq.w #1,(sp) don't forget to adjust exponent! bra.s step11 (d0,d1) equals zden * * Step 10. Adjust znum and compute zden. * stepp10 move.ltack. This algorithm is taken * from the book "Software Manual for the Elementary * Functions" by William Cody and William Waite. * * Author : Paul Beiser * * Revisions : 1.0 06/01/81 *  #$bfe00000,d2 subtract 0.5 moveq #0,d3 bsr radd znum correct, so now compute zden. movea.l d0,a2 first, save znum away movea.l d1,a3 moveq #-1,d7 compute zden <-- f * 0.5 + 0.5 move.l a0,d0 move.l a1,d1 2.0 09/01/83 For: * o Calls to software floating point * * Parameters : 4(sp) - real argument * * Registers : See text of the code. * * Result : Returned on the top of the stack. * * Error bsr adx f * 0.5 move.l #$3fe00000,d2 add 0.5 moveq #0,d3 bsr radd (d0,d1) contains zden; (a2,a3) has znum * * Step 11. First compute z and w. * step11 move.l d0,d2 place zden in correct registers for d(s) : An argument <= 0 returns an error. * * References : radd, rmul, rdvd, * soft_horner,soft_hornera, err_logerr * intrel, intxp, setxp, adx, cff_loga, cff_logb * *********************************************ivide move.l d1,d3 move.l a2,d0 z <-- znum / zden move.l a3,d1 bsr rdvd movea.l d0,a0 (a0,a1) <-- z movea.l d1,a1 move.l d0,d2 w <-- z * z move.l d1,d3 bsr rmul movea.l d0,a2 (a2,a3) <-- ********************************** soft_ln move.l 4(sp),d0 ble err_logerr branch if less than or = to zero move.l 8(sp),d1 * * Continue with the natural logarithm. * movem.l a5-a6,-(sp) save dedicated registers bsr intxp w movea.l d1,a3 * * Evaluate A(w) and store the result on the stack. * movea.l d0,a4 place w in correct registers movea.l d1,a5 lea cff_loga,a6 address of the coefficients moveq #2,d0 degree of the polynomial bsr  extract the exponent; operand in (d0,d1) move.w d7,-(sp) place exponent into memory clr.w d7 map number into range [0.5,1) bsr setxp compute value of f movea.l d0,a0 save f in (a0,a1) movea.l d1,a1 m soft_horner do the polynomial evaluation movem.l d0-d1,-(sp) * * Evaluate B(w) and leave result in (d0,d1). * movea.l a2,a4 place w in correct registers movea.l a3,a5 lea cff_logb,a6 address of the coefficients moveq #3,d0 ove.l #$bfe00000,d2 combine f - 0.5 of step 9 and 10 moveq #0,d3 bsr radd znum <-- (d0,d1) * * Compare f against sqrt(1/2) to determine the correct branch. * cmpa.l #$3fe6a09e,a0 upper part of constant sqrt(1/2) bgt.s stepp10 degree of the polynomial bsr soft_hornera do the polynomial evaluation * * Evaluate R(z) = z + z * (w * A(w)/B(w)). * move.l d0,d2 place B(w) in correct registers for divide move.l d1,d3 movem.l (sp)+,d0-d1 retrieve A('     Software Manual for the Elementary Functions" by * William Cody and William Waite. * * Author : Paul Beiser * * Revisions : 1.0 06/01/81 * : 2.0 09/01/83 For: * o Hardware fa0) (f3,f2) <- f movem.l bogus4(a0),d4-d5 tst.w divl_f0_f2(a0) (f3,f2) <- f/y0 movem.l bogus4(a0),d4-d5 tst.w addl_f2_f0(a0) (f1,f0) <- y0 + f/y0 = z movem.l bogus4(a0),d4-d5 * * Compute y2 = .25*z + f/z. Note that y1loating point * o To check for -0 as a valid input * * Parameters : 4(sp) - real argument * * Registers : a0 - address of the floating point card * d7 - original exponent of ar is not computed. * tst.w movl_f6_f2(a0) (f3,f2) <- f movem.l bogus4(a0),d4-d5 tst.w divl_f0_f2(a0) (f3,f2) <- f/z movem.l bogus4(a0),d4-d5 move.l #$3fd00000,movf_m_f5(a0) (f5,f4) <- .25 move.l #0,movf_m_f4(a0) tst.w mw) bsr rdvd (d0,d1) <-- A(w)/B(w) move.l a2,d2 get w in (d2,d3) move.l a3,d3 bsr rmul (d0,d1) <-- w * A(w)/B(w) move.l a0,d2 place z in (d2,d3) move.l a1,d3 bsr rmul (d0,d1) <-- gument * (f6,f7) - f * (f0,f1) - partial results * d4,d5 - results of the bogus reads * * Result : Returned on the top of the stack. * * Error(s) : An argument < 0 returnz * (w * A(w)/B(w)) move.l a0,d2 (a0,a1) still has z move.l a1,d3 bsr radd (d0,d1) <-- z + z * (w * A(w)/B(w)) movea.l d0,a0 (a0,a1) <-- R(z) movea.l d1,a1 * * Finish the computation. * move.w (sp)+,d0 s an error. * * References : intxp, setxp, adx, flpt_cardaddr, err_sqrterr * ******************************************************************************* flpt_sqrt move.l 8(sp),d1 move.l 4(sp),d0 bmi errmaybe branch if negaget integer exponent ext.l d0 bsr lntrel convert exponent into a real movea.l d0,a2 (a2,a3) <-- xn movea.l d1,a3 move.l #$bf2bd010,d2 move.l #$5c610ca8,d3 bsr rmul xn * c2 move.l a0,d2 get R(tive bne.s f@sqrok if non-zero, have positive number rts else result = operand = 0 * * Continue with the square root. * f@sqrok lea flpt_cardaddr,a0 point to the start of the hardware bsr z) move.l a1,d3 bsr radd xn * c2 + R(z) movem.l d0-d1,-(sp) save intermediate result move.l a2,d0 get xn move.l a3,d1 move.l #$3fe63000,d2 moveq #0,d3 bsr rmul xn * c1 movem.l (sp)+,d2-d3 r intxp extract exponent move.w d7,d6 save exponent clr.w d7 new unbiased exponent bsr setxp (d0,d1) is now f * * Compute initial guess of y0 = 0.41731 + 0.59016 * f. * mestore intermediate result bsr radd (xn * c2 + R(z)) + (xn * c1) * * Place result on the stack and return. * movem.l (sp)+,a5-a6 restore dedicated registers move.l d1,8(sp) move.l d0,4(sp) rts page **************************ovem.l d0-d1,movf_m_f7(a0) f will be in (f7,f6) throughout move.l #$3fe2e297,movf_m_f1(a0) constant .59016 move.l #$396d0918,movf_m_f0(a0) the rest of it tst.w mull_f6_f0(a0) (f1,f0) <- .59016 * f movem.l bogus4(a0),d4-d5 wait ***************************************************** * * Procedure : flpt_sqrt * * Description: Compute the square root of the numeric item on top * of the stack. This algorithm is taken from the book * "until the chip has finished move.l #$3fdab535,movf_m_f3(a0) constant .41731 move.l #$0092ccf7,movf_m_f2(a0) the rest of it tst.w addl_f2_f0(a0) (f1,f0) <- y0 movem.l bogus4(a0),d4-d5 * * Compute z = (y0 + f/y0). * tst.w movl_f6_f2((     ull_f4_f0(a0) (f1,f0) <- .25*z movem.l bogus4(a0),d4-d5 tst.w addl_f2_f0(a0) (f1,f0) <- f/z + .25*z = y2 movem.l bogus4(a0),d4-d5 * * Compute y3 = .5 * (y2 + f/y2). * tst.w movl_f6_f2(a0) (f3,f2) <- f movem.l bogus4(aBeiser * * Revisions : 1.0 06/01/81 * 2.0 09/01/83 For: * o Calls to software floating point * o To check for -0 as valid input * * Parameters : 4(sp) - real argu0),d4-d5 tst.w divl_f0_f2(a0) (f3,f2) <- f/y2 movem.l bogus4(a0),d4-d5 tst.w addl_f2_f0(a0) (f1,f0) <- f/y2 + y2 movem.l bogus4(a0),d4-d5 move.l #$3fe00000,movf_m_f3(a0) (f3,f2) <- .5 move.l #0,movf_m_f2(a0) tst.w mullment * * Registers : See text of the code. * * Result : Returned on the top of the stack. * * Error(s) : An argument < 0 returns an error. * * References : radd, rmul, rdvd, intxp, setxp, adx, err_sqrterr * ******************_f2_f0(a0) (f1,f0) <- .5 * (y2 + f/y2) movem.l bogus4(a0),d4-d5 * * Test for even or odd exponent, and adjust accordingly. * move.w d6,d7 save the original exponent asr.w #1,d7 the original exponent bcc************************************************************* soft_sqrt move.l 8(sp),d1 move.l 4(sp),d0 bmi.s errmaybe branch if negative bne.s sqrok if non-zero, have positive number rts else result = oper.s f@evenexp branch if the exponent was even move.l #$3fe6a09e,movf_m_f3(a0) (f3,f2) <- sqrt(1/2) move.l #$667f3bcd,movf_m_f2(a0) tst.w mull_f2_f0(a0) (f1,f0) <- (f1,f0) * sqrt(1/2) movem.l bogus4(a0),d4-d5 and = 0 * * Continue with the square root. * sqrok bsr intxp extract exponent movea.w d7,a4 save exponent clr.w d7 new unbiased exponent bsr setxp (d0,d1) is now f * * Compute initial guess of y0  addq.w #1,d6 (n+1) / 2 --> m f@evenexp asr.w #1,d6 adjust the old exponent move.l movf_f1_m(a0),d0 retrieve the last partial result move.l movf_f0_m(a0),d1 move.w d6,d7 place here for t= 0.41731 + 0.59016 * f. * movea.l d0,a0 (a0,a1) <-- f movea.l d1,a1 move.l #$3fe2e297,d2 constant 0.59016 move.l #$396d0918,d3 bsr rmul (d0,d1) contains first term move.l #$3fdab535,d2 constant 0.41731 move.l #$0he adx bsr adx put in the result exponent * * Place result on the stack. * move.l d0,4(sp) move.l d1,8(sp) rts * * Negative number, so check for sqrt(-0). * errmaybe cmp.l #minuszero,d0 first, check for a -0 b092ccf7,d3 bsr radd (d0,d1) has initial guess for y movea.l d0,a2 (a2,a3) <-- y movea.l d1,a3 * * Compute z = (y0 + f/y0). * move.l d0,d2 (d2,d3) <-- y0 move.l d1,d3 move.l a0,d0 (d0,d1) <-- f movene err_sqrterr rts else return with -0 as the result page ******************************************************************************* * * Procedure : soft_sqrt * * Description: Compute the square root .l a1,d1 bsr rdvd f/y0 move.l a2,d2 (d2,d3) <-- y0 move.l a3,d3 bsr radd (d0,d1) <-- z = y0 + f/y0 movea.l d0,a2 (a2,a3) <- z movea.l d1,a3 * * Compute y2 = .25*z + f/z. Note that y1 is not compof the numeric item on the * top of the stack. This algorithm is taken * from the book "Software Manual for the Elementary * Functions" by William Cody and William Waite. * * Author : Paul uted. * move.l d0,d2 (d2,d3) <- z move.l d1,d3 move.l a0,d0 (d0,d1) <- f move.l a1,d1 bsr rdvd f/z move.l d0,d2 (d2,d3) <- f/z move.l d1,d3 move.l a2,d0 (d0,d1) <- z move.l a3,d1 (      from the book "Software Manual for the Elementary * Functions" by William Cody and William Waite. * * Author : Paul Beiser * * Revisions : 1.0 06/01/81 * 2.0 09/01/83 For: *  #q,status(a0) see if had an underflow beq f@arc34 branch if no underflow move.l #$3ff921fb,d0 top part of pi/2 move.l #$54442d18,d1 rest of result of pi/2 tst.l d6 ch o Hardware floating point * o To check for -0 as a valid operand * * Parameters : 4(sp) - real argument * * Registers : a0 - address of the floating point card * d7 eck sign of original operand bpl f@donee pos arguement yields positive result bset #31,d0 if negative, result is negative bra f@donee place result on stack and return f@arc34 ts moveq #-2,d7 'adx' does not affect (d2,d3) = f/z bsr adx .25*x bsr radd y2 <-- .25*x + f/z movea.l d0,a2 (a2,a3) <- y2 movea.l d1,a3 * * Compute y3 = .5 * (y2 + f/y2). * move.l d0,d2 pla- n * d6 - sign of the argument * d4-d5 - results of the bogus reads * * Result : Returned on the top of the stack. * * Error(s) : An argument too large returns an error. * * Referece y2 in divisor registers move.l d1,d3 move.l a0,d0 load up the value of f; y is in (d0,d1) move.l a1,d1 bsr rdvd f/y computed; result in (d0,d1) move.l a2,d2 get y2 move.l a3,d3 bsr radd y2nces : flpt_horner, flpt_hornera, compare, cff_atnp, cff_atnq, * flpt_cardaddr * ******************************************************************************* flpt_arctan move.l 4(sp),d0 get the argument move.l 8(sp),d1 + f/y2 computed; result in (d0,d1) moveq #-1,d7 bsr adx y = y3 <- 0.5 * (y2 + f/y2) * * Test for even or odd exponent, and adjust accordingly. * move.w a4,d7 get the initial exponent guess asr.w #1,d7 see if  lea flpt_cardaddr,a0 must save all the fp registers movem.l a5-a6,-(sp) save Pascal dedicated registers move.l d0,d6 save the sign cmp.l #minuszero,d6 check if a -0 bne.s act@1 even or odd bcc.s evenexp branch if even exponent move.l #$3fe6a09e,d2 else adjust mantissa accordingly move.l #$667f3bcd,d3 constant sqrt(1/2) bsr rmul y <- y * sqrt(1/2) move.w a4,d7 get old expo branch if not a -0 moveq #0,d6 set the sign to + act@1 bclr #31,d0 f <- abs(x) movem.l d0-d1,movf_m_f1(a0) (f0,f1) <- f * * Adjust f if > 1. Note that underflow is possible if x is real large. * If undenent addq.w #1,d7 adjust it asr.w #1,d7 (n + 1) / 2 --> m evenexp bsr adx d7 has result exponent; (d0,d1) the rest * * Place result on the stack. * move.l d0,4(sp) move.l d1,8(sp) rts page ********rflowed, then the argument was real large, so return pi/2 as * the angle. * move.l #$3ff00000,d2 floating point 1 moveq #0,d3 bsr compare bgt.s f@invertf branch if have to invert f moveq #0,d7 *********************************************************************** * * Procedure : flpt_arctan * * Description: Compute the arctangent of the numeric item on the * top of the stack. This algorithm is taken *  else set n to 0 bra.s f@step7 and continue with the computation f@invertf movem.l d2-d3,movf_m_f3(a0) (f2,f3) <- 1 tst.w divl_f0_f2(a0) (f2,f3) <- 1/f movem.l bogus4(a0),d4-d5 wait for the chip to finish btst )     t.w movl_f2_f0(a0) no error, so (f0,f1) <- f = 1/f movem.l bogus4(a0),d4-d5 moveq #2,d7 n <- 2 * * Adjust f if > 2 - sqrt(3). * f@step7 move.l movf_f1_m(a0),d0 get f move.l movf_f0_m(a0),d1 move.l #$3fd12614, the coefficients tst.w movl_f0_f6(a0) (f6,f7)<- f (untouched by horner(a)) movem.l bogus4(a0),d4-d5 bsr flpt_horner compute pg; result in (f0,f1) movem.l a4-a5,movf_m_f3(a0) (f2,f3) <- g tst.w mull_f0d2 2 - sqrt(3) move.l #$5e9ecd56,d3 bsr compare ble.s f@steep10 branch if no more adjusting of f or n addq.w #1,d7 step 8; first adjust n move.l #$3ffbb67a,movf_m_f3(a0) (f2,f3) <- sqrt(3) _f2(a0) (f2,f3) <- g * p(g) movem.l bogus4(a0),d4-d5 moveq #4,d0 degree for the next polynomial lea cff_atnq,a6 movea.l movf_f3_m(a0),a2 (a2,a3) <- g * p(g) movea.l movf_f2_m(a0),a3 bsr  move.l #$e8584caa,movf_m_f2(a0) tst.w addl_f0_f2(a0) (f2,f3) <- f + sqrt(3) movem.l bogus4(a0),d4-d5 move.l #$3fe76cf5,movf_m_f5(a0) (f4,f5) <- sqrt(3) - 1 = a move.l #$d0b09955,movf_m_f4(a0) tst.w mull_f0_f4(a0)  flpt_hornera compute q(g); result in (f0,f1) movem.l a2-a3,movf_m_f3(a0) (f2,f3) <- g * p(g) tst.w divl_f0_f2(a0) (f2,f3) <- g * p(g) / q(g) movem.l bogus4(a0),d4-d5 tst.w mull_f6_f2(a0) (f2,f3) <- f*g* (f4,f5) <- a*f movem.l bogus4(a0),d4-d5 move.l #$bfe00000,movf_m_f7(a0) (f6,f7) <- -1/2 move.l #0,movf_m_f6(a0) tst.w addl_f6_f4(a0) (f4,f5) <- a*f - 1/2 movem.l bogus4(a0),d4-d5 tst.w addl_f6_f4(a0) p(g)/q(g) movem.l bogus4(a0),d4-d5 tst.w addl_f2_f6(a0) result= (f6,f7) <- f + f*g*p(g)/q(g) movem.l bogus4(a0),d4-d5 * * Finish the computation. * f@step15 tst.w d7 check n beq.s f@checksgn f (f4,f5) <- (a*f - 1/2) - 1/2 movem.l bogus4(a0),d4-d5 tst.w addl_f4_f0(a0) (f0,f1) <- ((a*f - 1/2) - 1/2) + f movem.l bogus4(a0),d4-d5 tst.w divl_f2_f0(a0) (f0,f1) <- (f0,f1)/denominator = f movem.l bogus4(ast path if n is zero cmp.w #1,d7 bne.s f@val23 branch if adjustment to result move.l #$3fe0c152,movf_m_f3(a0) (f2,f3) <- a(1) = pi/6 move.l #$382d7366,movf_m_f2(a0) tst.w addl_f2_f6(a0) (f6a0),d4-d5 * * Evaluate the polynomials if required. (f0,f1) <- f. * f@steep10 tst.w movl_f0_f6(a0) result must be in (f6,f7) for later movem.l bogus4(a0),d4-d5 move.l movf_f1_m(a0),d0 get f move.l movf_f0_m(a0),d1 bclr #31,d0 ,f7) <- res + pi/6 movem.l bogus4(a0),d4-d5 bra.s f@checksgn f@val23 tst.w negl_f6_f6(a0) else result <- -result movem.l bogus4(a0),d4-d5 cmp.w #2,d7 check n for either a 2 or 3 beq.s f@val2  abs(f) move.l #$3e46a09e,d2 eps = 2^(-53/2) move.l #$667f3bcd,d3 bsr compare is abs(f) < eps? blt f@step15 tst.w movl_f0_f2(a0) (f2,f3) <- f movem.l bogus4(a0),d4-d5 tst.w  branch if equal to 2 move.l #$3ff0c152,movf_m_f3(a0) (f2,f3) <- a(3) = pi/3 move.l #$382d7366,movf_m_f2(a0) tst.w addl_f2_f6(a0) (f6,f7) <- res + pi/3 movem.l bogus4(a0),d4-d5 bra.s f@checksgmull_f2_f2(a0) (f2,f3) <- f*f = g movem.l bogus4(a0),d4-d5 movea.l movf_f3_m(a0),a4 (a4,a5) <- g movea.l movf_f2_m(a0),a5 moveq #3,d0 degree of the polynomial lea cff_atnp,a6 point ton f@val2 move.l #$3ff921fb,movf_m_f3(a0) (f2,f3) <- a(2) = pi/2 move.l #$54442d18,movf_m_f2(a0) tst.w addl_f2_f6(a0) (f6,f7) <- res + pi/2 movem.l bogus4(a0),d4-d5 * f@checksgn move.l movf_f7_m(a0),d0 (d0,d1) <- result)     tore correct order of the operand cmpi.l #minuszero,d0 check for a -0 bne.s sftat@1 branch if not a -0 move.w #1,(sp) else change sign to + sftat@1 bclr #31,d0 f <- abs(x) * * Adjust f if > 1. Underflow is possible e.l a3,d3 bsr rdvd new f * * Evaluate the polynomials if required. * steep10 movea.l d0,a0 save the sign of f bclr #31,d0 abs(f) move.l #$3e46a09e,d2 eps = 2^(-53/2) move.l #$667f3bcd,d3 bsr compare here if f is real large. * move.l #$3ff00000,d2 floating point 1 moveq #0,d3 bsr compare bgt.s invertf branch if have to invert f clr.w -(sp) else set n to 0 bra.s step7 and continue with the computa is abs(f) < eps? blt.s step12a move.l a0,d0 restore sign of f movea.l d1,a1 (a0,a1) <- f move.l d0,d2 move.l d1,d3 bsr rmul g <- f * f movea.l d0,a4 (a4,a5) <- g move move.l movf_f6_m(a0),d1 tst.l d6 check sign of original argument bpl.s f@donee bchg #31,d0 negate sign of result * * Place result on the stack and return. * f@donee movem.l (sp)+,a5-a6 retion invertf exg d0,d2 place 1 as the dividend, and exg d1,d3 f as the divisor move.l sysglobals-10(a5),-(sp) TRY, could get real underflow pea recoverr address for the RECOVER move.l sp,sysglobals-1store Pascal dedicated registers move.l d0,4(sp) move.l d1,8(sp) rts page ******************************************************************************* * * Procedure : soft_arctan * * Description: Compute the arctangent of the nume0(a5) new TRY block bsr rdvd reciprocate the argument addq.l #4,sp pop off the error address move.l (sp)+,sysglobals-10(a5) restore old TRY block move.w #2,-(sp) n <- 2 * * Save value of n. Adjust f ifric item on the * top of the stack. This algorithm is taken * from the book "Software Manual for the Elementary * Functions" by William Cody and William Waite. * * Author : Paul Beiser * *  > 2 - sqrt(3). * step7 move.l #$3fd12614,d2 2 - sqrt(3) move.l #$5e9ecd56,d3 bsr compare ble.s steep10 branch if no more adjusting of f or n required addq.w #1,(sp) step 8; first adjust n movea.l d0,a0  Revisions : 1.0 06/01/81 * 2.0 09/01/83 For: * o Calls to software floating point * o To check for -0 as a valid operand * * Parameters : 4(sp) - real argument * (a0,a1) <- f movea.l d1,a1 move.l #$3ffbb67a,d2 sqrt(3) move.l #$e8584caa,d3 bsr radd f + sqrt(3) movea.l d0,a2 save denominator for now movea.l d1,a3 move.l #$3fe76cf5,d0 a = sqrt(3) - 1 * Registers : See text of the code. * * Result : Returned on the top of the stack. * * Error(s) : None * * References : radd, rmul, rdvd, soft_horner, soft_hornera, compare, * cff_atnp, cff_atnq * *********move.l #$d0b09955,d1 move.l a0,d2 get f move.l a1,d3 bsr rmul a * f move.l #$bfe00000,d2 -1/2 movea.l d2,a4 save for next radd moveq #0,d3 bsr radd a * f - 1/2 mov********************************************************************** soft_arctan move.l 4(sp),d0 move.l 8(sp),d1 movem.l a5-a6,-(sp) save dedicated registers swap d0 save the sign move.w d0,-(sp) swap d0 rese.l a4,d2 -1/2 moveq #0,d3 bsr radd (a * f - 1/2) - 1/2 move.l a0,d2 get f move.l a1,d3 bsr radd ( (a * f - 1/2) - 1/2) + f move.l a2,d2 restore f + sqrt(3) mov*     a.l d1,a5 moveq #3,d0 degree of the polynomial lea cff_atnp,a6 point to the coefficients bsr soft_horner move.l a4,d2 get g move.l a5,d3 bsr rmul g * p(g) movea.l d0,a2  of result of pi/2 tst.w (sp)+ check sign of original operand bpl donee positive argument yields positive result bset #31,d0 if negative, result is negative bra donee place result on stack and r (a2,a3) <- g * p(g) movea.l d1,a3 moveq #4,d0 degree for the next polynomial lea cff_atnq,a6 bsr soft_hornera q(g) move.l d0,d2 divisor move.l d1,d3 move.l a2,d0 dividend eturn page ******************************************************************************* * * Procedures : Assorted * * Description: The rest of the procedures are a collection of * utility interface routines for the compil move.l a3,d1 bsr rdvd g * p(g) / q(g) move.l a0,d2 get f move.l a1,d3 bsr rmul f * g * p(g) / q(g) move.l a0,d2 get f move.l a1,d3 bsr radd result <- f + fer. * See the text of the procedures for information * concerning them. * * Author : Brad Ritter * * Revisions : 1.0 06/01/81 * *************************************************************************g*p(g)/q(g) bra.s step15 step12a move.l a0,d0 f is the result * * Finish the computation. * step15 move.w (sp)+,d7 retrieve n beq.s checksgn fast path if n is zero cmp.w #1,d7 bne.s val23 branch******* asm_bcdround equ * movea.l (sp)+,a0 return address movea.l (sp)+,a1 address of string move.w (sp)+,d0 number of digits movea.l (sp)+,a2 address of bcd_strtype addq.l #3,a1 point to s[3] movea.l a1,a3  if adjustment to result necesary move.l #$3fe0c152,d2 a(1) = pi/6 move.l #$382d7366,d3 bsr radd bra.s checksgn val23 bchg #31,d0 else result <- -result cmp.w #2,d7 check n for eithe save address of s[3] addq.l #2,a2 point to first bcd digit * * Move the digits to s[3..17] * moveq #8,d1 count bcdr1 move.b (a2)+,d3 move.b d3,d4 andi.b #$F,d4 andi.b #$F0,d3 lsr.b #4,d3 move.b d3,(a1)+ movr a 2 or 3 beq.s val2 branch if equal to 2 move.l #$3ff0c152,d2 a(3) = pi/3 move.l #$382d7366,d3 bsr radd bra.s checksgn val2 move.l #$3ff921fb,d2 a(2) = pi/2 move.l #$54442d18,d3 e.b d4,(a1)+ subq.b #1,d1 bgt.s bcdr1 * * Round to proper number of digits * lea 0(a3,d0.w),a1 address off digit to round addq.b #5,(a1) bcdr2 cmpi.b #10,(a1) blt.s bcdr5 subi.b #10,(a1) cmpa.l a1,a3 beq.s bcdr3 all d bsr radd * checksgn tst.w (sp)+ check sign of original argument bpl.s donee bchg #31,d0 negate sign of result * * Place result on the stack and return. * donee movem.l (sp)+,a5-a6 restore dedicated registers moone but final carry subq.l #1,a1 addq.b #1,(a1) bra.s bcdr2 * bcdr3 move.b #49,(a3)+ '1' subq.b #1,d0 bcdr4 move.b #48,(a3)+ '0' subi.b #1,d0 bge.s bcdr4 add 1 extra 0 * * Increment exponent by 1 * addq.w #1,(a2ve.l d0,4(sp) move.l d1,8(sp) rts * * Argument was too large. Return pi/2 as the result. * recoverr move.l (sp)+,sysglobals-10(a5) restore TRY block move.l #$3ff921fb,d0 else underflowed, so get top part of pi/2 move.l #$54442d18,d1 rest) jmp (a0) * * Convert to characters * bcdr5 addi.b #48,(a3)+ subi.b #1,d0 bgt.s bcdr5 jmp (a0) asm_pack movea.l (sp)+,a0 return address move.l (sp)+,d0 count move.w (sp)+,d1 field width (1,2,4,8,16) move.w (s*     th (1,2,4,8,16) move.w (sp)+,d2 unpacksize (1,2,4) movea.l (sp)+,a2 source movea.l (sp)+,a1 destination move.b (sp)+,d3 signed fields ? clr.w d4 bit index move.l a1,d5 bclr #0,d5 make dest  value range error asm_octal movea.l 4(sp),a0 address of string clr.l d0 result move.b (a0)+,d2 length of string beq.s error {sb} oct@l1 clr.l d1 move.b (a0)+,d1 cmpi.b #32,d1 ord(' ') = 32 bne.seven beq.s unpack movea.l d5,a1 move.w #8,d4 unpack move.l (a2),d5 lsl.l d4,d5 left justify field move.w d1,d6 subi.w #32,d6 neg.w d6 32 - fieldwidth tst.b d3 bne.s unpack1 lsr.l d6,d5 right just oct@l2 subq.b #1,d2 bgt.s oct@l1 bra.s error {sb} oct@l5 clr.l d1 move.b (a0)+,d1 oct@l2 subi.w #48,d1 ord('0') = 48 blt.s tstblk cmpi.w #7,d1 bgt.s error move.l d0,d3 andi.l #$E0000000,d3 bne.s error asp)+,d2 unpacksize (1,2,4) movea.l (sp)+,a1 destination movea.l (sp)+,a2 source clr.w d4 bit index move.l a1,d5 bclr #0,d5 make dest even beq.s pack movea.l d5,a1 move.w #8,d4 pack cmpi.w #2ify unsigned bra.s unpack2 unpack1 asr.l d6,d5 right justify signed unpack2 add.w d1,d4 increment bit index cmpi.w #15,d4 ble.s unpack3 subi.w #16,d4 addq.l #2,a2 unpack3 cmpi.w #2,d2 unpacksize = 2 ? bne.s,d2 unpacksize = word ? bne.s pack1 move.w (a2)+,d3 bra.s pack3 pack1 cmpi.w #1,d2 unpacksize = byte ? bne.s pack2 move.b (a2)+,d3 bra.s pack3 pack2 move.l (a2)+,d3 unpacksize = long pack3 move.w d4,d5 unpack4 move.w d5,(a1)+ bra.s unpack6 unpack4 cmpi.w #1,d2 unpacksize =1 ? bne.s unpack5 move.b d5,(a1)+ bra.s unpack6 unpack5 move.l d5,(a1)+ unpack6 subq.l #1,d0 bne.s unpack jmp (a0) asm_hex movea.l 4(sp),a0  bit index subi.w #32,d5 add.w d1,d5 neg.w d5 #32 - offset - width cmpi.w #16,d1 fieldwidth = 16 ? bne.s pack4 move.l #65535,d6 bra.s pack8 pack4 cmpi.w #8,d1 fieldwidth = 8 ? bne.s pack5  address of string clr.l d0 result move.b (a0)+,d2 length of string beq.s error {sb} h@x1 clr.l d1 move.b (a0)+,d1 cmpi.b #32,d1 ord(' ') = 32 bne.s h@x2 subq.b #1,d2 bgt.s h@x1 bra.s err move.l #255,d6 bra.s pack8 pack5 cmpi.w #4,d1 fieldwidth = 4 ? bne.s pack6 moveq #15,d6 bra.s pack8 pack6 cmpi.w #2,d1 fieldwidth = 2 ? bne.s pack7 move.l #3,d6 bra.s pack8 pack7 moveq #1,d6 or {sb} h@x5 clr.l d1 move.b (a0)+,d1 h@x2 subi.w #48,d1 ord('0') = 48 blt.s tstblk cmpi.w #9,d1 ble.s h@x3 subi.w #17,d1 ord('A') = 65 {sb} blt.s error cmpi.w #5,d1 {sb} ble.s h@x6 fieldwidth = 1 pack8 lsl.l d5,d6 position mask lsl.l d5,d3 position source and.l d6,d3 mask off source not.l d6 and.l d6,(a1) clr dest field or.l d3,(a1) store source in dest add.w d1,d4 {sb} subi.w #32,d1 ord('a') = 97 blt.s error cmpi.w #5,d1 {sb} bgt.s error h@x6 addi.w #10,d1 {sb} h@x3 move.l d0,d3 andi.l #$F0000000,d3 bne.s error asl.l #4,d0 add.l d1,d0 subq.b #1,d2 bgt increment bit index cmpi.w #15,d4 ble.s pack9 subi.w #16,d4 addq.l #2,a1 pack9 subq.l #1,d0 bne.s pack jmp (a0) asm_unpack movea.l (sp)+,a0 return address move.l (sp)+,d0 count move.w (sp)+,d1 field wid.s h@x5 h@x4 move.l d0,4(sp) rts tstblk addi.w #48,d1 tstblk0 cmpi.b #32,d1 test for trailing blanks bne.s error subq.b #1,d2 ble.s h@x4 move.b (a0)+,d1 bra.s tstblk0 error move.w #-8,sysglobals-2(a5) trap #10 +     l.l #3,d0 add.l d1,d0 subq.b #1,d2 bgt.s oct@l5 oct@l4 move.l d0,4(sp) rts asm_binary movea.l 4(sp),a0 address of string clr.l d0 result move.b (a0)+,d2 length of string beq.s error {sb} bin@ry1 clr.l.l (sp)+,d0-d3 d0,d1 - opnd1 d2,d3 - opnd2 bsr compare bgt rettrue bra retfalse asm_ge movea.l (sp)+,a0 return address movem.l (sp)+,d0-d3 d0,d1 - opnd1 d2,d3 - opnd2 bsr compare bge rettrue bra retfalse  d1 move.b (a0)+,d1 cmpi.b #32,d1 ord(' ') = 32 bne.s bin@ry2 subq.b #1,d2 bgt.s bin@ry1 bra.s error {sb} bin@ry5 clr.l d1 move.b (a0)+,d1 bin@ry2 subi.w #48,d1 ord('0') = 48 blt.s tstblk cmpi.w #1,d1  page **************************************************************************** * * Code for all the math errors. * err_intover trap #4 err_divzero move.w #esc_flpt_divzer,sysglobals-2(a5) trap #10 err_overflow move.w #esc_flpt_over,sys bgt.s error asl.l #1,d0 bcs.s error add.l d1,d0 subq.b #1,d2 bgt.s bin@ry5 bin@ry4 move.l d0,4(sp) rts asm_addsetrange equ * ************************************************* * d3, d4, a4 are not used by addelement * ***********globals-2(a5) trap #10 err_underflow move.w #esc_flpt_under,sysglobals-2(a5) trap #10 err_trigerr move.w #esc_flpt_sincos,sysglobals-2(a5) trap #10 err_logerr move.w #esc_flpt_natlog,sysglobals-2(a5) trap #10 err_sq************************************** movea.l (sp)+,a4 return address move.w (sp)+,d3 hivalue move.w (sp)+,d4 lovalue cmp.w d3,d4 ble.s e@add move.l (sp)+,(sp) e@end jmp (a4) e@add ext.l d4 move.l d4,-(sp) jsrterr move.w #esc_flpt_sqrt,sysglobals-2(a5) trap #10 err_illnumbr move.w #esc_flpt_relbcd,sysglobals-2(a5) trap #10 err_impvalue move.w #esc_flpt_bcdrel,sysglobals-2(a5) trap #10 err_miscel move.w #esc_flpt_misc,sysglobalr asm_adelement addq.w #1,d4 cmp.w d3,d4 bgt e@end move.l (sp),-(sp) bra.s e@add *********************************************************************** retfalse clr.b -(sp) false jmp (a0) rettrue move.b #1,-(sp) s-2(a5) trap #10 end  true jmp (a0) *********************************************************************** asm_eq movea.l (sp)+,a0 return address movem.l (sp)+,d0-d3 d0,d1 - opnd1 d2,d3 - opnd2 bsr compare beq rettrue bra retfalse asm_ne$MODCAL,UCSD,sysprog,partial_eval,range off$ $iocheck off,ovflcheck off$ program allrealstuff; module mfs; $copyright 'COPYRIGHT (C) 1982 BY HEWLETT-PACKARD COMPANY'$ import sysglobals,fs,sysdevs,misc,asm; export var flpt_present['FLTPTHDW']: boo movea.l (sp)+,a0 return address movem.l (sp)+,d0-d3 d0,d1 - opnd1 d2,d3 - opnd2 bsr compare bne rettrue bra retfalse asm_lt movea.l (sp)+,a0 return address movem.l (sp)+,d0-d3 d0,d1 - opnd1 d2,d3 - opnd2 bsr lean; {*** NOTE ABSOLUTE ADDRESS !!! } procedure freadreal (var t: text; var x: real); procedure fwritereal(var t: text; x: real; w,d: shortint); procedure freadstrreal (var s: string255; var p2: integer; var x: real); procedure fwritestrreal(var r: st compare blt rettrue bra retfalse asm_le movea.l (sp)+,a0 return address movem.l (sp)+,d0-d3 d0,d1 - opnd1 d2,d3 - opnd2 bsr compare ble rettrue bra retfalse asm_gt movea.l (sp)+,a0 return address movemring;var p2: integer;x: real; w,d: shortint); IMPLEMENT const nlen = 255; type stringnlen = string[nlen]; sourcetype = (strg,phile); BCDdigit = 0..15; {0..9 are used} bcd_strtype = record signbit: (pls,mnus); mantissa:+     s] := chr; end else begin if (chr = backspace) or (chr = DEL) then begin check_chr; if ((number[nchars] < '0') or (number[nchars] > '9')) then goto 9; end else escape(3); {end of input} end; end; 9:chr := number[ncharsl 9; begin while true do begin get1char; if (chr >= '0') and (chr <= '9') then {ok} begin nchars := nchars + 1; number[nchars] := chr; end else if chr = '.' then begin nchars := nchars + 1; number[nchars] := chr; fracs]; end; { expodigit } procedure gotexposign; { looking for } label 9; begin while true do begin get1char; if (chr >= '0') and (chr <= '9') then begin nchars := nchars + 1; number[nchars] := chr; expodigit; tate; end else if (chr = 'E') or (chr = 'e') or (chr = 'L') or (chr = 'l') then begin nchars := nchars + 1; number[nchars] := chr; expostate; end else begin if (chr = backspace) or (chr = DEL) then begin check_chr;  packed array[1..16] of BCDdigit; exponent: shortint; end; var nextchr: shortint; procedure asm_bcd_real(s: bcd_strtype; x: real); external; procedure inputreal(stype: sourcetype; anyvar f: text; fstrg: string255; var end else begin if (chr = backspace) or (chr = DEL) then begin check_chr; goto 9; end else escape(2); { error } end; end; 9: chr := number[nchars]; end; { gotexposign } procedure expostate; { looking for , '+', '-' } label 9; begin while true do begin get1char; if (chr >= '0') and (chr <= '9') then begin nchars := nchars + 1; number[nchars] := chr; expodigit; end else if (chr = '+') or (chr = '-') then begin ncharsen if stype = phile then begin i := nchars; killchar(f,i); nchars := i; firstchar := true; escape(1); end else { stype = strg } nchars := 0 else { chr = backspace } if stype = phile then begin i := nchars; killchar(f,i); n := nchars + 1; number[nchars] := chr; gotexposign; end else begin if (chr = backspace) or (chr = DEL) then begin check_chr; goto 9; end else escape(2); { error } end; end; 9: chr := number[nchars]; end; chars := i; firstchar := true; end else nchars := nchars - 1; end; procedure get1char; begin if nchars=nlen then escape(2); if stype = strg then begin nextchr := nextchr + 1; if nextchr > strlen(fstrg) then if streof the procedure fracstate; { looking for , 'E', 'e', 'L', 'l' } label 9; begin while true do begin get1char; if (chr = 'E') or (chr = 'e') or (chr = 'L') or (chr = 'l') then begin nchars := nchars + 1; number[nchars] := n escape(2) else streof := true; if streof or (fstrg[nextchr]=eol) then chr := blank else chr := fstrg[nextchr]; end else {stype = phyle} begin if not firstchar then get(f); firstchar := false; chr := f^; if ioresult <> ord(inoerror)chr; expostate; end else if (chr >= '0') and (chr <= '9') then begin nchars := nchars + 1; number[nchars] := chr; end else begin if (chr = backspace) or (chr = DEL) then begin check_chr; if nchars = 0 then escape(1) then escape(2); end; end; { get1char } procedure expodigit; { looking for } label 9; begin while true do begin get1char; if (chr >= '0') and (chr <= '9') then begin nchars := nchars + 1; number[nchar; if (number[nchars+1] = '.') then goto 9; end else escape(3); { end of input } end; end; 9: chr := number[nchars]; end; { fracstate } procedure mantissadigitA; { looking for , '.', 'E', 'e', 'L', 'l' } labe,      if nchars = 0 then escape(1); end else escape(3); { end of input } end; end; 9: chr := number[nchars]; end; { mantissadigitA } procedure mantissadigitB; { looking for , '.', 'E', 'e', 'L', 'l' } label 9; begin gin if (chr = backspace) or (chr = DEL) then begin check_chr; escape(1); end else if (chr <> blank) then escape(2); { error } end; end; end; { startstate } begin { inputreal } streof := false; firstchar :=  while true do begin get1char; if (chr >= '0') and (chr <= '9') then {ok} begin nchars := nchars + 1; number[nchars] := chr; end else if (chr = '.') then begin nchars := nchars + 1; number[nchars] := chr; fracstate; end eltrue; 1: try startstate; recover if escapecode = 1 then goto 1 else if escapecode = 2 then { error } begin if ioresult = ord(inoerror) then IORESULT := ord(IBADFORMAT); end else if escapecode = 3 then begin nchars :=se if (chr = 'E') or (chr = 'e') or (chr = 'L') or (chr = 'l') then begin nchars := nchars + 1; number[nchars] := chr; expostate; end else begin if (chr = backspace) or (chr = DEL) then begin check_chr; if ((number[nc nchars + 1; number[nchars] := blank; end else escape(escapecode); end; { inputreal } procedure getrealnumber(var number: stringnlen; var x: real); var bcd_str: bcd_strtype; mantissa_digit,i,expsign, nextchar,extraexponent: shorhars] = '+') or (number[nchars] = '-')) then goto 9; end else escape(3); { end of input } end; end; 9: chr := number[nchars]; end; { mantissadigitB } procedure gotmantissasign; { looking for , '.' } label 9; begintint; xvalid,decpnt,nonzero: boolean; ch: char; begin with bcd_str do begin xvalid := false; exponent := 0; { 2's comp exponent } extraexponent := 0; { amount of normalization } mantissa_digit := 1; { nex while true do begin get1char; if (chr >= '0') and (chr <= '9') then begin nchars := nchars + 1; number[nchars] := chr; mantissadigitB; end else if chr = '.' then begin nchars := nchars + 1; number[nchars] := chr; fracst digit to be inserted } signbit := pls; { sign of real number } decpnt := false; { have we seen a decimal point } nonzero := false; { nonzero digit encountered } for i := 1 to 16 do mantissa[i] := 0; nextchar := 1tate; end else begin if (chr = backspace) or (chr = DEL) then begin check_chr; if nchars = 0 then escape(1); end else escape(2); { error } end; end; 9: chr := number[nchars]; end; procedure startstate; { l; repeat ch := number[nextchar]; nextchar := nextchar + 1; until (ch <> ' '); if (ch = '+') or (ch = '-') then begin if ch = '-' then signbit := mnus; ch := number[nextchar]; nextchar := nextchar + 1; end; while ch = '0' do ooking for '+', '-', '.', } begin nchars := 0; setstrlen(number,strmax(number)); while true do begin get1char; if (chr >= '0') and (chr <= '9') then begin nchars := nchars + 1; number[nchars] := chr; mantissadigbegin xvalid := true; ch := number[nextchar]; nextchar := nextchar + 1; end; while (ch >= '0') and (ch <= '9') do begin nonzero := true; xvalid := true; if mantissa_digit <= 16 then mantissa[mantissa_digit] := ord(ch) - ord('0'); mantissaitA; end else if (chr = '+') or (chr = '-') then begin nchars := nchars + 1; number[nchars] := chr; gotmantissasign; end else if chr = '.' then begin nchars := nchars + 1; number[nchars] := chr; fracstate; end else be_digit := mantissa_digit + 1; ch := number[nextchar]; nextchar := nextchar + 1; end; if ch = '.' then begin extraexponent := mantissa_digit - 1; decpnt := true; ch := number[nextchar]; nextchar := nextchar + 1; while not nonzero and (ch = '0,     rocedure freadreal(var t: text; var x: real); var number: stringnlen; begin { freadreal } if not fibp(addr(t))^.freadable then ioresult := ord(inotreadable) else begin { scs 1/17/83 } ior begin if numdigits > 15 then numdigits := 15; asm_bcdround(bcd_str,numdigits,s); if (d < 0) or (exponent >= 15) then begin { scientific notation } s[2] := s[3]; s[3] := '.'; j := numdigits + 3; s[j] := 'E'; j := j + 1; if exponentesult := ord(inoerror); if eof(t) then ioresult := ord(ieof) else inputreal(phile,t,'',number); if ioresult = ord(inoerror) then getrealnumber(number,x); end; end; { freadreal } procedure freadstrreal(var s: string255; < 0 then begin s[j] := '-'; exponent := -exponent; end else s[j] := '+'; j := j + 1; s[j] := chr(exponent DIV 100 + ord('0')); j := j + 1; s[j] := chr((exponent MOD 100) DIV 10 + ord('0')); j := j + 1; s[j] := ') do begin xvalid := true; extraexponent := extraexponent - 1; ch := number[nextchar]; nextchar := nextchar + 1; end; while (ch >= '0') and (ch <= '9') do begin xvalid := true; nonzero := true; if mantissa_digit <= 16 then  var p2: integer; var x: real); var number: stringnlen; xxxxx: shortint; begin nextchr := 0; ioresult := ord(inoerror); if (p2<1) or (p2>strlen(s)) then ioresult := ord(istrovfl) else inputreal(strg,xxxxx,str(s,p2,strlen(s)-p2+ mantissa[mantissa_digit] := ord(ch) - ord('0'); mantissa_digit := mantissa_digit + 1; ch := number[nextchar]; nextchar := nextchar + 1; end; end; if (ch in ['e','E','l','L']) and xvalid then begin ch := number[nextchar]; nextchar 1),number); if ioresult = ord(inoerror) then begin p2 := p2 + nextchr - 1; getrealnumber(number,x); end; end; procedure asm_bcdround(bcd: bcd_strtype; d: shortint; var s: string255); external; procedure asm_:= nextchar + 1; if ch in ['+','-','0'..'9'] then begin exponent := 0; expsign := 1; if (ch = '-') or (ch = '+') then begin if ch = '-' then expsign := -1; ch := number[nextchar]; nextchar := nextchar + 1; end; tryreal_bcd(x: real; s: bcd_strtype); external; procedure fwritestrreal (var r: string; var p2: integer; x: real; w,d: shortint); var bcd_str: bcd_strtype; s: string255; i,j,numdigits,minwidth: shortint; begin {fwritestrreal} ioresult while (ch >= '0') and (ch <= '9') do begin exponent := exponent * 10 - ord('0') + ord(ch); ch := number[nextchar]; nextchar := nextchar + 1; end; exponent := exponent * expsign; recover if escapeco := ord(inoerror); setstrlen(s,255); if x < 0 then begin minwidth := 9; x := -x; s[1] := '-'; end else begin minwidth := 8; s[1] := ' '; end; if (d > 252) then d := -1; if w < 0 thende = -4 then { intover } xvalid := false else escape(escapecode); end else xvalid := false; end; if xvalid then if nonzero then begin if not decpnt then extraexponent := mantissa_digit - 1; exponent := exponent + extraexpo w := 12; asm_real_bcd(x,bcd_str); with bcd_str do begin if x <> 0 then { mantissa between 1 and 10 } exponent := exponent - 1; if (d < 0) or (exponent >= 15) then begin if (w < minwidth) then w := minwidth; numdigits := w - nent; try asm_bcd_real(bcd_str,x); recover if escapecode = -20 then escape(escapecode) else IORESULT := ord(IBADFORMAT); end else x := 0.0 else IORESULT := ord(IBADFORMAT); end; end; { getrealnumber } p(minwidth - 2) end else numdigits := d + exponent + 1; if numdigits < 0 then { number is 0.0 } begin s[1] := '0'; s[2] := '.'; if d > 0 then setstrlen(s,d+2) else setstrlen(s,1); for j := 3 to strlen(s) do s[j] := '0'; end else-     chr(exponent MOD 10 + ord('0')); setstrlen(s,j); end else { fixed point notation } if exponent >= 0 then begin for i := 2 to exponent + 2 do s[i] := s[i+1]; s[3+exponent] := '.'; if d > 14 - exponent then d := 14 RIGHTS LEGEND Use, duplication, or disclosure by the Government is subject to restrictions as set forth in paragraph (b) (3) (B) of the Rights in Technical Data and Computer Software clause in DAR 7-104.9(a). HEWLETT-PACKARD COMPANY Fort Collins, Colora - exponent; if d = 0 then setstrlen(s,2+exponent) else setstrlen(s,3+d+exponent); end else begin { numdigits may have changed } numdigits := d + exponent + 1; if numdigits > 14 then numdigits := 14; for do *) $SYSPROG$ $DEBUG OFF$ $RANGE ON , PARTIAL_EVAL, OVFLCHECK OFF,STACKCHECK OFF$ $COPYRIGHT '(C) 1985 HEWLETT-PACKARD CO. 3.1'$ MODULE REVASM_MOD; { This module is used by the debugger for X format execution } IMPORT ASM; EXPORTi := numdigits+2 downto 3 do s[i-exponent] := s[i]; s[2] := '0'; s[3] := '.'; fillchar(s[4],-exponent-1,'0'); if d > 14 then d := 14; if d = 0 then setstrlen(s,2) else setstrlen(s,3+d); end; end; if s[1] = PROCEDURE REVASM(ANYVAR INSP:INTEGER; VAR S:STRING; ANYVAR NXTP,FTYPE:INTEGER); implement PROCEDURE REVASM(ANYVAR INSP:INTEGER; VAR S:STRING; ANYVAR NXTP,FTYPE:INTEGER); CONST MAXOPS = 34; TYPE UWORD = 0..65535; BYTE = 0..25 ' ' then {get rid of blank} begin moveleft(s[2],s[1],strlen(s)-1); setstrlen(s,strlen(s)-1); end; if w < strlen(s) then w := strlen(s); strwrite(r,p2,p2,s:w); end; { with bcd_str } end; { fwritestrreal } procedure fwritereal (v5; IWORDA = PACKED ARRAY [1..MAXOPS] OF UWORD; INAMEA = ARRAY[1..MAXOPS] OF STRING[13]; IBYTEA = PACKED ARRAY [1..MAXOPS] OF BYTE; REGBITS = PACKED ARRAY[0..15] OF BOOLEAN; WORD = -32768..32767; SBYTE = -128..127; HEXD = 0..15;ar t: text; x: real; w,d: shortint); var s: string255; dummy: integer; begin setstrlen(s,0); $range off$ strwrite(s,1,dummy,x:w:d); if ioresult = ord(inoerror) then fwritebytes(t,s[1],strlen(s)); end; end; { module mfs } import mf STRING1 = STRING[1]; INSTREC = PACKED RECORD CASE INTEGER OF 0 :(BYTE0 : BYTE; BYTE1 : SBYTE); 1: (OPCODE : 0..15; IREG2 : 0..7; IMODE2 : 0..7; IMODE1 : 0..7; IREG1 : 0..7); 2: (IWORD : UWORD)s; procedure asm_flpt_reset; external; begin { Code to initialize floating point hardware -- 10/26/83 jws } try flpt_present:=false; asm_flpt_reset; flpt_present:=true; recover if escapecode<>-12 { bus err} then escape(escape; 3: (HEX0 : HEXD; { OPCODE } HEX1 : HEXD; HEX2 : HEXD; HEX3 : HEXD); 4: (BIT15 : BOOLEAN; BIT14 : BOOLEAN; BIT13 : BOOLEAN; BIT12 : BOOLEAN; BIT11 : BOOLEAN; BIT10 : BOOLEAN; BIT9 : BOOLEAcode); end. {more file support} N; BIT8 : BOOLEAN; BIT7 : BOOLEAN; BIT6 : BOOLEAN; BIT5 : BOOLEAN; BIT4 : BOOLEAN; BIT3 : BOOLEAN; BIT2 : BOOLEAN; BIT1 : BOOLEAN; BIT0 : BOOLEAN); 5: (DUM1 : HEXD; DATA : 0..7; BITX8 (* (c) Copyright Hewlett-Packard Company, 1985. All rights are reserved. Copying or other reproduction of this program except for archival purposes is prohibited without the prior written consent of Hewlett-Packard Company. RESTRICTED : BOOLEAN; OPSIZE : 0..3; fpredicate : 0..63); 6: (DUM2 : HEXD; DUM3 : 0..7; OPSIZE1: 0..3); END; EAXREC = PACKED RECORD CASE INTEGER OF 1:(EXOFFWORD : WORD); 2:(EXOFFLONG : INTEGER); 3:-     ; OPMASKS= IWORDA[ HEX('F000'),HEX('F1C0'),HEX('F000'),HEX('F1C0'), HEX('F000'),HEX('F000'),HEX('FFC0'),HEX('FFC0'), HEX('FFFF'),HEX('FFFF'),HEX('FFFF'),HEX('FFFF'), HEX('FFFF'),HEX('FFFF'),HEX('FFFF'),HEX('F100'), HEX('FFF8) AND (REG1>4) THEN ESCAPE(0); END; PROCEDURE M1M7R1CHECK; BEGIN M7R1CHECK; IF (MODE1=1) THEN ESCAPE(0); END; PROCEDURE M1M7R4CHECK; BEGIN M7R4CHECK; IF (MODE1=1) THEN ESCAPE(0); END; procedure m1m3m4check; begin '),HEX('FFF8'),HEX('FFF8'),HEX('FFF8'), HEX('FFF8'),HEX('FFFF') ,HEX('F000'),HEX('F000'),HEX('F000'),HEX('F000'), HEX('F000'),HEX('F000'),HEX('F000'),HEX('F000'), HEX('F000') ,HEX('F000'),HEX('F000'),HEX('0000')]; OPN if (mode1=1) or (mode1=3) or (mode1=4) then escape(0); end; procedure m1m3m4m7r1check; begin m1m3m4check; m7r1check; end; procedure m1m3m4m7r4check; begin m1m3m4check; if (mode1=7) and (reg1=4) t(EXB0 : BYTE; EXB1 : BYTE); 4:(EXDABIT : BOOLEAN; EXREG : 0..7; EXWLBIT : BOOLEAN; exscale : 0..3; case fullindex : boolean of false: (exoffbyte : -128..127); true: (exbs : boolean; exis : boolean;AMES= INAMEA['MOVE.B ','MOVEA.L ','MOVE.L ','MOVEA.W ', 'MOVE.W ','BRA','JSR ','JMP ', 'RTS','RESET','NOP','STOP # ', 'RTE','TRAPV','RTR','MOVEQ # ', 'UNLK A','EXT.W D','EXT.L D','SWAP D', 'MOVE USP,A','RTD # ' ,'0...',' exbdsize : 0..3; expadbit : boolean; exindirect : 0..7)); 5:(expad1 : hexd; exDo : boolean; exoffset : 0..31; exDw : boolean; exwidth : 0..31); 6:(expad2 : 0..127; exDu : 0..7; expad3 : 0..7; exDc : 0..4...','5...','8...', '9...','B...','C...','D...', 'E...' ,'A...','F...','DC.W ']; OPCTRL = IWORDA[2,1,1,1, 1,6,3,3, 0,0,0,4, 0,0,0,7, 5,5,5,5, 5,4 ,8,9,10,11, 12,13,14,15, 16, 65537); 7:(fopclas : 0..7; frx : 0..7; fry : 0..7; case integer of 0: (fextension : 0..127); 1 :(fext : 0..15; sincosreg : 0..7); 2: (Kfactor : -64..63); 3: (KDreg : 0..7; zeros : 0..15)); END; E5,23,65535]; VAR EAX : EAXRECP; saveeax : EAXRECP; eaxplus2 : EAXRECP; original_eax : eaxrecp; INSR : RECORD CASE INTEGER OF 0:(INSTP:INSTRP); 1:(INSTI:INTEGER); END; I,J,K : INTEGER; MODE1,REG1,MAXRECP = ^EAXREC; INSTRP = ^INSTREC; OUTSTR = STRING[80]; CONST BRATYPE = 'RASRHILSCCCSNEEQVCVSPLMIGELTGTLE'; CCTYPE = 'T F HILSCCCSNEEQVCVSPLMIGELTGTLE'; BITTYPE = 'BTSTBCHGBCLRBSET'; SSIZE = 'BWL@'; SRTYPE = 'AS**LS**ODE2,REG2 : INTEGER; OPC,OSIZE : INTEGER; DONE : BOOLEAN; FUNCTION SREG(I:INTEGER):STRING1; BEGIN SREG := ' '; SREG[1] := CHR(I+ORD('0')); END; PROCEDURE APPENDREG(RT:INTEGER; RN:INTEGER); CONST REGNAME='D A FP '; BEGINROX*RO**'; OPBITS = IWORDA[ HEX('1000'),HEX('2040'),HEX('2000'),HEX('3040'), HEX('3000'),HEX('6000'),HEX('4E80'),HEX('4EC0'), HEX('4E75'),HEX('4E70'),HEX('4E71'),HEX('4E72'), HEX('4E73'),HEX('4E76'),HEX('4E77'),HEX('7000'),  S:=S+STR(REGNAME,RT*2+1,2); if rt = 2 { Float reg } then setstrlen(s,strlen(s)+1); S[STRLEN(S)]:=CHR(RN+ORD('0')); END; PROCEDURE COMMA; BEGIN S:=S+',';END; PROCEDURE NUMBERSIGN; BEGIN S:=S+'#';END; PROCEDURE BLANHEX('4E58'),HEX('4880'),HEX('48C0'),HEX('4840'), HEX('4E68'),HEX('4E74') ,HEX('0000'),HEX('4000'),HEX('5000'),HEX('8000'), HEX('9000'),HEX('B000'),HEX('C000'),HEX('D000'), HEX('E000') ,HEX('A000'),HEX('F000'),HEX('0000')]K; BEGIN S:=S+' ';END; PROCEDURE SUFFIX(N:INTEGER); CONST SUF='.B .W .L '; BEGIN S:=S+STR(SUF,N*3+1,3);END; PROCEDURE M7R1CHECK; BEGIN IF (MODE1=7) AND (REG1>1) THEN ESCAPE(0); END; PROCEDURE M7R4CHECK; BEGIN IF (MODE1=7.     hen escape(0); end; procedure bfreg; {additional Dreg for bit field ops} begin strwrite(s,strlen(s)+1,i,'D',saveeax^.exreg:1); end; procedure offset_width; begin with saveeax^ do begin s := s + '{'; if exDo 16 BIT DISPLACEMENT + A REGISTER } STRWRITE(S,STRLEN(S)+1,I,X^.EXOFFWORD:1,'(A',REG:1,')'); L:=2; END; 6: if not x^.fullindex then if x^.exscale = 0 then BEGIN { 8 BIT DISPLACEMENT+A REGISTER+INDEX REGISTER } STRWRITE(S,STRLEN then strwrite(s,strlen(s)+1,i,'D',exoffset:1) else strwrite(s,strlen(s)+1,i,exoffset:1); s := s + ':'; if exDw then strwrite(s,strlen(s)+1,i,'D',exwidth:1,'}') else if exwidth = 0 then s := s + '32}' else strwrite(s,strlen(s)+(S)+1,I,X^.EXOFFBYTE:1,'(A',REG:1,','); APPENDREG(ORD(X^.EXDABIT),X^.EXREG); SUFFIX(ORD(X^.EXWLBIT)+1); S[STRLEN(S)]:=')'; L:=2; END else begin strwrite(s,strlen(s)+1,i,'(',x^.exoffbyte:1,',A',reg:1,','); appendreg(o1,i,exwidth:1,'}'); end; end; PROCEDURE XREG(VAR XP:EAXREC); BEGIN APPENDREG(ORD(XP.EXDABIT),XP.EXREG); END; PROCEDURE CREG(VAR XP:EAXREC); BEGIN IF (XP.EXscale<>0) or (xp.fullindex) THEN ESCAPE(0); IF XP.EXWLBIT THrd(x^.exdabit),x^.exreg); suffix(ord(x^.exwlbit)+1); setstrlen(s,strlen(s)-1); { suffix added extra blank } case x^.exscale of 1: s := s + '*2)'; 2: s := s + '*4)'; 3: s := s + '*8)'; end; l :=EN IF XP.EXB1=0 THEN S:=S+'USP' ELSE if xp.exb1 = 1 then s := s + 'VBR' else if xp.exb1 = 2 then s := s + 'CAAR' else if xp.exb1 = 3 then s := s + 'MSP' else if xp.exb1 = 4 then s := s + 'ISP' else if xp.exb1 = 5 then s := s + 'MMUSR' { JWH 12/23/89  2; end else begin if x^.exindirect <> 0 then s := s + '([' else s := s + '('; savex := x; x := addr(x^,2); case savex^.exbdsize of 1: ; 2: begin strwrite(s,strlen(s)+1,i,x^.exoffword:1); x := add} else if xp.exb1 = 6 then s := s + 'URP' { JWH 12/23/89 } else if xp.exb1 = 7 then s := s + 'SRP' { JWH 12/23/89 } else escape(0) ELSE IF XP.EXB1=0 THEN S:=S+'SFC' ELSE if xp.exb1 = 1 then S:=S+'DFC' else if xp.exb1 = 2 then s := s + 'CACR' er(x^,2); end; 3: begin strwrite(s,strlen(s)+1,i,x^.exofflong:1); x := addr(x^,4); end; end; if not savex^.exbs then begin if (s[strlen(s)] <> '(') and (s[strlen(s)] <> '[') then comma; strwrite(s,strlen(s)+1,lse if xp.exb1 = 3 then s := s + 'TC' { JWH 12/23/89 } else if xp.exb1 = 4 then s := s + 'ITT0' { JWH 12/23/89 } else if xp.exb1 = 5 then s := s + 'ITT1' { JWH 12/23/89 } else if xp.exb1 = 6 then s := s + 'DTT0' { JWH 12/23/89 } else if xp.exb1 = 7 thei,'A',reg:1); end; if savex^.exindirect in [5,6,7] then s := s + ']'; if not savex^.exis then begin if (s[strlen(s)] <> '(') and (s[strlen(s)] <> '[') then comma; appendreg(ord(savex^.exdabit),savex^.exreg); n s := s + 'DTT1' { JWH 12/23/89 } else escape(0); END; PROCEDURE APPEND_INT(I:INTEGER); VAR P:INTEGER; BEGIN STRWRITE(S,STRLEN(S)+1,P,I:1); END; PROCEDURE DUMPEA(MODE,REG:INTEGER; VAR X:EAXRECP; SIZE : INTEGER); VAR I, suffix(ord(savex^.exwlbit)+1); setstrlen(s,strlen(s)-1); { suffix added extra blank } case savex^.exscale of 0: ; 1: s := s + '*2'; 2: s := s + '*4'; 3: s := s + '*8'; end; end; if saD,L : INTEGER; savex : eaxrecp; BEGIN L:=0; CASE MODE OF 0,1: APPENDREG(MODE,REG); 2: S := S + '(A' + SREG(REG) + ')'; 3: S := S + '(A' + SREG(REG) + ')+'; 4: S := S + '-(A' + SREG(REG) + ')'; 5: BEGIN {vex^.exindirect in [1,2,3] then s := s + ']'; case savex^.exindirect of 0,1,5: l := 0; 2,6 : begin if (s[strlen(s)] <> '(') and (s[strlen(s)] <> '[') then comma; strwrite(s,strlen(s)+1,i,x^.exoffword:1); l :.     := s + '0' else strwrite(s,strlen(s)+1,i,ORD(ADDR(X^))-2-INSR.INSTI+x^.exoffword:1); x := addr(x^,2); end; 3: begin if x^.exofflong = 0 then s := s + '0' else strwrite(s,strlen(s)+1,i,ORD(ADDR(X^))-2-INSR.INSFALSE; INLIST := FALSE; DONE := FALSE; LASTREG := 99; REGNUM := 0; REGCHAR := 'D'; IF ZFIRST THEN BITNUM := 0 ELSE BITNUM := 15; REPEAT IF REGLIST[BITNUM] THEN BEGIN IF REGNUM<>LASTREG+1 THEN BEGIN IF INLIST THEN TI+x^.exofflong:1); x := addr(x^,4); end; end; if (s[strlen(s)] <> '(' ) and (s[strlen(s)] <> '[') then comma; if not savex^.exbs then s := s + 'PC' else s := s + 'ZPC'; if savex^.exindirect in [5,6,7] theBEGIN S := S +'-'+REGCHAR+SREG(LASTREG); INLIST := FALSE; NEWLIST := TRUE; END; IF NEWLIST THEN S := S + '/'; S := S+REGCHAR+SREG(REGNUM); INLIST := FALSE; NEWLIST := TRUE; END ELSE BEGIN INLIST := TRUE; NEWLIST := 2; end; 3,7 : begin if (s[strlen(s)] <> '(') and (s[strlen(s)] <> '[') then comma; strwrite(s,strlen(s)+1,i,x^.exofflong:1); l := 4; end; 4: escape(0); end; s := s + ')'; end; 7: CASE Rn s := s + ']'; if not savex^.exis then begin if (s[strlen(s)] <> '(' ) and (s[strlen(s)] <> '[') then comma; appendreg(ord(savex^.exdabit),savex^.exreg); suffix(ord(savex^.exwlbit)+1); setstrlen(s,strlen(s)-1); { suffix addEG OF 0: BEGIN { SHORT ABSOLUTE } APPEND_INT(X^.EXOFFWORD); L:=2; END; 1: BEGIN { LONG ABSOLUTE } APPEND_INT(X^.EXOFFLONG); L:=4; END; 2: BEGIN { PC + DISPLACEMENT } D := ORD(ADDR(X^))-INSR.INSTI+X^.EXOFFWORD; IF D<0 THEed extra blank } case savex^.exscale of 0: ; 1: s := s + '*2'; 2: s := s + '*4'; 3: s := s + '*8'; end; end; if savex^.exindirect in [1,2,3] then s := s + ']'; case savex^.exindirect of 0,1,5: l := 0; 2,6 : begin N S := S + '*' ELSE S := S + '*+'; APPEND_INT(D); L:=2; END; 3: if not x^.fullindex then if x^.exscale = 0 then BEGIN { PC + INDEX REG } D := ORD(ADDR(X^))-INSR.INSTI+X^.EXOFFBYTE; IF D<0 THEN S := S + '*' ELSE S := S + '*+ if x^.exoffword = 0 then s := s + ',0' else strwrite(s,strlen(s)+1,i,',',x^.exoffword:1); l := 2; end; 3,7 : begin if x^.exofflong = 0 then s := s + ',0' else strwrite(s,strlen(s)+1,'; STRWRITE(S,STRLEN(S)+1,I,D:1,'('); APPENDREG(ORD(X^.EXDABIT),X^.EXREG); SUFFIX(ORD(X^.EXWLBIT)+1); S[STRLEN(S)]:=')'; L:=2; END else begin if x^.exoffbyte = 0 then strwrite(s,strlen(s)+1,i,'(0,PC,') else strwrite(s,strlen(s)i,',',x^.exofflong:1); l := 4; end; end; s := s + ')'; end; 4: BEGIN { IMMEDIATE } NUMBERSIGN; CASE SIZE OF 0: BEGIN APPEND_INT(X^.EXOFFBYTE); L:=2; END; 1: BEGIN APPEND_INT(X^.E+1,i,'(',x^.exoffbyte:1,',PC,'); appendreg(ord(x^.exdabit),x^.exreg); suffix(ord(x^.exwlbit)+1); setstrlen(s,strlen(s)-1); { suffix added extra blank } case x^.exscale of 1: s := s + '*2)'; 2: s := s + '*4)'; 3: s := s + '*8)';XOFFWORD); L:=2; END; 2,3: BEGIN APPEND_INT(X^.EXOFFLONG); L:=4; END; OTHERWISE END; { CASE SIZE } END; { REG 4 } OTHERWISE END; { CASE REG } END; { CASE MODE } X := ADDR(X^,L); END;  end; l := 2; end else begin if x^.exindirect <> 0 then s := s + '([' else s := s + '('; savex := x; x := addr(x^,2); case savex^.exbdsize of 1: ; 2: begin if x^.exoffword = 0 then s  { DUMPEA } PROCEDURE DUMPREGBITS(ANYVAR REGLIST : REGBITS;ZFIRST : BOOLEAN); VAR REGNUM,BITNUM : INTEGER; REGCHAR : STRING[1]; LASTREG : INTEGER; NEWLIST,INLIST,DONE : BOOLEAN; BEGIN NEWLIST := /     = FALSE; END; LASTREG := REGNUM; END; REGNUM := REGNUM + 1; IF ZFIRST THEN BITNUM := BITNUM + 1 ELSE BITNUM := BITNUM - 1; IF REGNUM>7 THEN BEGIN IF INLIST THEN S := S + '-'+REGCHAR+SREG(LASTREG); IF REGCHAR='D' THEN BEGIN NEWLIST : packed record case boolean of true: (b: byte); false:(a: packed array[0..7] of boolean); end; regnum, bitnum, lastbit : integer; function makestring(c: char): string1; var s: string1; begin setstrlen(s,1) := LASTREG<>99; INLIST := FALSE; REGCHAR := 'A'; REGNUM := 0; LASTREG := 99; END ELSE DONE:=TRUE; END; UNTIL DONE; END; procedure dumpfea(mode,reg: integer; var x: eaxrecp; size: integer); type hexarray = array[0..15; s[1] := c; makestring := s; end; procedure hithit; forward; procedure hitmiss; forward; procedure hithithit; begin if zfirst then bitnum := bitnum + 1 else bitnum := bitnum - 1; regnum := regnum + 1; ] of char; const hex = hexarray['0','1','2','3','4','5','6','7','8','9', 'A','B','C','D','E','F']; var j,l : integer; variantrec : packed record case integer of 0: (i: integer); 1: (h: packed array[1..24] of 0 if bitnum <> lastbit then if variantrec.a[bitnum] then hithithit else begin s := s + 'FP' + makestring(chr(ord('0')+regnum-1)); hitmiss; end else s := s + 'FP' + makestring(chr(ord('0')+regnum-1)); end; procedure mis..15); 2: (i1,i2,i3: integer); end; begin if (mode = 7) and (reg = 4) then { Immediate } begin s := s + '#'; case size of 0: {L} BEGIN APPEND_INT(X^.EXOFFLONG); L:=4; END; 1: {S} begin variantrec.i := x^.exofshit; begin s := s + '/FP' + makestring(chr(ord('0')+regnum)); if zfirst then bitnum := bitnum + 1 else bitnum := bitnum - 1; regnum := regnum + 1; if bitnum <> lastbit then if variantrec.a[bitnum] then hithit else hitmflong; s := s + '$'; for j := 1 to 8 do strwrite(s,strlen(s)+1,i,hex[variantrec.h[j]]); l := 4; end; 2,3: {X,P} begin variantrec.i1 := x^.exofflong; x := addr(x^,4); variantrec.i2 := x^.exofflong; x :iss; end; procedure hitmiss; begin if zfirst then bitnum := bitnum + 1 else bitnum := bitnum - 1; regnum := regnum + 1; if bitnum <> lastbit then if variantrec.a[bitnum] then misshit else hitmiss; end; p= addr(x^,4); variantrec.i3 := x^.exofflong; s := s + '$'; for j := 1 to 24 do strwrite(s,strlen(s)+1,i,hex[variantrec.h[j]]); l := 4; end; 4: {W} BEGIN APPEND_INT(X^.EXOFFWORD); L:=2; END; 5: {D} begin variantrec.rocedure hithit; begin if zfirst then bitnum := bitnum + 1 else bitnum := bitnum - 1; regnum := regnum + 1; if (bitnum = lastbit) then begin s := s + '-FP' + makestring(chr(ord('0')+regnum-1)); end else if not variantrec.i1 := x^.exofflong; x := addr(x^,4); variantrec.i2 := x^.exofflong; s := s + '$'; for j := 1 to 16 do strwrite(s,strlen(s)+1,i,hex[variantrec.h[j]]); l := 4; end; 6: {B} BEGIN APPEND_INT(X^.EXOFFBYTE); L:a[bitnum] then begin s := s + '-FP' + makestring(chr(ord('0')+regnum-1)); hitmiss; end else begin s := s + '-'; hithithit; end; end; procedure firsthit; begin s := s + 'FP' + makestring(chr(ord('0')+regnum)); if z=2; END; otherwise escape(0); end; {case} eax := addr(eax^,l); end else dumpea(mode,reg,x,size); end; procedure dumpfregbits(reglist : byte; zfirst : boolean); type string1 = string[1]; var variantrecfirst then bitnum := bitnum + 1 else bitnum := bitnum - 1; regnum := regnum + 1; if bitnum <> lastbit then if variantrec.a[bitnum] then hithit else hitmiss; end; procedure firstmiss; begin if zfirst then bitnum := /      27: s := s + 'NLT'; 28: s := s + 'NGE'; 29: s := s + 'NGT'; 30: s := s + 'SNE'; {LAF 870407 to match manual} 31: s := s + 'ST'; otherwise escape(0); end; end; procedure mc68881; begin if mode2 = 0 t2)) then {Dn, An, (An)+, PC modes, Imm} escape(0); dumpea(mode1,reg1,eax,0); end; end else if eax^.fopclas >= 4 then { FMOVE sysreg } begin if eax^.frx in [1,2,4] then s := 'FMOVE ' else s := 'FMOVEM '; if (eax^.fry <> 0) or (eahen if eax^.fopclas >= 6 then { FMOVEM } begin s := 'FMOVEM '; if eax^.fopclas = 6 then { move to FP data registers } begin saveeax := eax; eax := addr(eax^,2); if (mode1 = 0) or (mode1 = 1) or (mode1 = 4) or ((mode1 = 7) and (rex^.fextension <> 0) then escape(0); if eax^.fopclas = 4 then { move to sysregs } begin saveeax := eax; eax := addr(eax^,2); dumpea(mode1,reg1,eax,2); case saveeax^.frx of 0: escape(0); 1: s := s + ',FPIADDR'; 2: begin bitnum + 1 else bitnum := bitnum - 1; regnum := regnum + 1; if bitnum <> lastbit then if variantrec.a[bitnum] then firsthit else firstmiss; end; begin variantrec.b := reglist; if zfirst then begin bitnum :=g1 = 4)) then { Dn, An, -(An), Imm } escape(0); dumpea(mode1,reg1,eax,0); comma; if saveeax^.frx = 6 then { D reg } begin if saveeax^.fry <> 0 then escape(0); { check for zero fields } appendreg(0,saveeax^.KDreg); if savee 0; lastbit := 8; end else begin bitnum := 7; lastbit := -1; end; regnum := 0; if variantrec.a[bitnum] then firsthit else firstmiss; end; procedure appendfloatsize(size : integer); begin ax^.zeros <> 0 then escape(0); { zero fields ? } end else if saveeax^.frx = 4 then { register mask } begin if saveeax^.fry > 1 then escape(0); { check for zero fields } dumpfregbits(saveeax^.exb1,true); end else escape(0);  case size of 0: s := s + '.L '; 1: s := s + '.S '; 2: s := s + '.X '; 3,7: s := s + '.P '; 4: s := s + '.W '; 5: s := s + '.D '; 6: s := s + '.B '; otherwise escape(0); end; {case} end; procedure  end else { move from FP data registers } begin if (eax^.frx = 2) or (eax^.frx = 6) then begin if eax^.fry <> 0 then escape(0); { check for zero fields } if eax^.frx = 2 then { only allow pre decr } if mode1 <> 4 { -(An) } thenappendfloatcondition(predicate : integer); begin case predicate of 0: s := s + 'F'; 1: s := s + 'EQ'; 2: s := s + 'OGT'; 3: s := s + 'OGE'; 4: s := s + 'OLT'; 5: s := s + 'OLE'; 6: s := s + 'OGL';  escape(0); if eax^.frx = 6 then { do not allow pre decr } if mode1 = 4 { -(An) } then escape(0); if eax^.zeros <> 0 then escape(0); { zero fields ? } appendreg(0,eax^.KDreg); end else if (eax^.frx = 0) or (eax^.frx = 4) then  7: s := s + 'OR'; 8: s := s + 'UN'; 9: s := s + 'UEQ'; 10: s := s + 'UGT'; 11: s := s + 'UGE'; 12: s := s + 'ULT'; 13: s := s + 'ULE'; 14: s := s + 'NEQ'; 15: s := s + 'T'; 16: s := s + 'SF';  begin if eax^.frx = 0 then { only allow pre decr } if mode1 <> 4 { -(An) } then escape(0); if eax^.frx = 4 then { do not allow pre decr } if mode1 = 4 { -(An) } then escape(0); if eax^.fry > 1 then escape(0); { check for z 17: s := s + 'SEQ'; 18: s := s + 'GT'; 19: s := s + 'GE'; 20: s := s + 'LT'; 21: s := s + 'LE'; 22: s := s + 'GL'; 23: s := s + 'LEG'; 24: s := s + 'NLEG'; 25: s := s + 'NGL'; 26: s := s + 'NLE'; ero fields } if eax^.frx = 0 then dumpfregbits(eax^.exb1,false) else dumpfregbits(eax^.exb1,true); end else escape(0); comma; eax := addr(eax^,2); if (mode1 = 0) or (mode1 = 1) or (mode1 = 3) or ((mode1 = 7) and (reg1 >= 0      if mode1 = 1 then { An } escape(0); s := s + ',FPSTATUS'; end; 3: begin if (mode1 = 1) or (mode1 = 0) or ((mode1 = 7) and (reg1 = 4)) then { An or Dn or Imm} escape(0); s := s + ',FPSTATUS/FPIADDR'; end;'; strwrite(s,strlen(s)+1,i,eax^.fextension:1,','); appendreg(2,eax^.fry); eax := addr(eax^,2); end else { general } begin case eax^.fextension of 0: s := 'FMOVE'; 1: s := 'FINT'; 2: s := 'FSINH'; 3: s := 'FINTRZ'; (* LAF 861204 4: begin if mode1 = 1 then { An } escape(0); s := s + ',FPCONTROL'; end; 5: begin if (mode1 = 1) or (mode1 = 0) or ((mode1 = 7) and (reg1 = 4)) then { An or Dn or Imm} escape(0); s := s + ',FPCONTRO *) 4: s := 'FSQRT'; 6: s := 'FLOGNP1'; 8: s := 'FETOXM1'; 9: s := 'FTANH'; 10:s := 'FATAN'; 12:s := 'FASIN'; 13:s := 'FATANH'; 14:s := 'FSIN'; 15:s := 'FTAN'; 16:s := 'FETOX'; 17:s := 'FTWOTOX'; 18:s := 'FTENTOX'; 20L/FPIADDR'; end; 6: begin if (mode1 = 1) or (mode1 = 0) or ((mode1 = 7) and (reg1 = 4)) then { An or Dn or Imm } escape(0); s := s + ',FPCONTROL/FPSTATUS'; end; 7: begin if (mode1 = 1) or (mode1 = 0):s := 'FLOGN'; 21:s := 'FLOG10'; 22:s := 'FLOG2'; 24:s := 'FABS'; 25:s := 'FCOSH'; 26:s := 'FNEG'; 28:s := 'FACOS'; 29:s := 'FCOS'; 30:s := 'FGETEXP'; 31:s := 'FGETMAN'; 32:s := 'FDIV'; 33:s := 'FMOD'; 34:s := 'FADD';  or ((mode1 = 7) and (reg1 = 4)) then { An or Dn or Imm } escape(0); s := s + ',FPCONTROL/FPSTATUS/FPIADDR'; end; end; {case} end else { move from sysregs } begin if ((mode1 = 7) and (reg1 > 1)) then escape(0); case e 35:s := 'FMUL'; 36:s := 'FSGLDIV'; 37:s := 'FREM'; 38:s := 'FSCALE'; 39:s := 'FSGLMUL'; 40:s := 'FSUB'; 48..55:s := 'FSINCOS'; 56:s := 'FCMP'; 58:s := 'FTST'; 64 : s := 'FSMOVE'; { JWH 12/23/89 } 65 : s := 'FSSQRT'; { JWHax^.frx of 0: escape(0); 1: s := s + 'FPIADDR,'; 2: begin if mode1 = 1 then { An } escape(0); s := s + 'FPSTATUS,'; end; 3: begin if (mode1 = 1) or (mode1 = 0) then { An or Dn } escape(0); s := s  12/23/89 } 68 : s := 'FDMOVE'; { JWH 12/23/89 } 69 : s := 'FDSQRT'; { JWH 12/23/89 } 88 : s := 'FSABS'; { JWH 12/23/89 } 90 : s := 'FSNEG'; { JWH 12/23/89 } 92 : s := 'FDABS'; { JWH 12/23/89 } 94 : s := 'FDNEG'; { JWH 12/23/8+ 'FPSTATUS/FPIADDR,'; end; 4: begin if mode1 = 1 then { An } escape(0); s := s + 'FPCONTROL,'; end; 5: begin if (mode1 = 1) or (mode1 = 0) then { An or Dn } escape(0); s := s + 'FPCONTROL/FPIADDR,'9 } 96 : s := 'FSDIV'; { JWH 12/23/89 } 98 : s := 'FSADD'; { JWH 12/23/89 } 99 : s := 'FSMUL'; { JWH 12/23/89 } 100 : s := 'FDDIV'; { JWH 12/23/89 } 102 : s := 'FDADD'; { JWH 12/23/89 } 103 : s := 'FDMUL'; { JWH 12/23/89 } 104 ; end; 6: begin if (mode1 = 1) or (mode1 = 0) then { An or Dn } escape(0); s := s + 'FPCONTROL/FPSTATUS,'; end; 7: begin if (mode1 = 1) or (mode1 = 0) then { An or Dn } escape(0); s := s + 'FPCONTRO: s := 'FSSUB'; { JWH 12/23/89 } 108 : s := 'FDSUB'; { JWH 12/23/89 } otherwise ; end; {case} if eax^.fopclas = 0 then { source is Freg } begin if (mode1 <> 0) or (reg1 <> 0) then escape(0); blank; appendreg(2,eax^.frx); if (eax^.L/FPSTATUS/FPIADDR,'; end; end; {case} eax := addr(eax^,2); dumpea(mode1,reg1,eax,0); end; end else if (eax^.fopclas = 2) and (eax^.frx = 7) then { FMOVECR } begin if (mode1 <> 0) or (reg1 <> 0) then escape(0); s := 'FMOVECR #fextension = 58 {FTST}) or ((eax^.frx = eax^.fry) and (eax^.fextension <> 0 {FMOVE}) and (eax^.fextension < 32)) then { Do not display second op for FTST or "single op" instructions } else begin comma; if eax^.fext = 6 then { F0     FTRAP' (* LAF 861204 *) else if (mode1 = 7) and ((reg1 = 2) or (reg1 = 3)) then s := 'FTRAP' (* LAF 861204 *) else s := 'FS'; appendfloatcondition(eax^.exb1); eax := addr(eax^,2); if mode1 = 1 then begin hen {Dn, An, (An)+, Imm, PC} escape(0); s := 'FSAVE '; end else begin if (mode1 = 0) or (mode1 = 1) or (mode1 = 4) or ((mode1 = 7) and (reg1 = 4)) then {Dn, An, -(An), Imm} escape(0); s := 'FRESTORE ' if s = 'FDBF' then s := 'FDBRA ' else blank; appendreg(0,reg1); comma; s := s + '*'; k := eax^.exoffword; k := k +4; { avoid 16 bit math } eax := addr(eax^,2); if k >= 0 then s := s + '+'; ; end; dumpea(mode1,reg1,eax,1); end; otherwise escape(0); end {case}; done := true; end; { mc68881 } { Added 12/24/89 JWH : } procedure move16; { Handle the '040 move16 instruction } type move16_type = packed reSINCOS } begin appendreg(2,eax^.sincosreg); s := s + ':'; end; appendreg(2,eax^.fry); end; eax := addr(eax^,2); end else if eax^.fopclas = 2 then { source is } begin if mode1 = 1 then { An } escape(0) strwrite(s,strlen(s)+1,i,k:1); end else if (mode1 = 7) and (reg1 = 4) then { FTcc } else if (mode1 = 7) and (reg1 = 2) then begin { FTPcc.W } s := s + '.W #'; strwrite(s,strlen(s)+1,i,eax^.exoffword:1); eax := a; if mode1 = 0 then { Dn } if eax^.frx in [2,3,5] then { size - X,P,D } escape(0); appendfloatsize(eax^.frx); saveeax := eax; eax := addr(eax^,2); dumpfea(mode1,reg1,eax,saveeax^.frx); if saveeax^.fextension <> 58 {FTST} then bddr(eax^,2); end else if (mode1 = 7) and (reg1 = 3) then begin { FTPcc.L } s := s + '.L #'; strwrite(s,strlen(s)+1,i,eax^.exofflong:1); eax := addr(eax^,4); end else begin blank; if (mode1 = 1) egin comma; if saveeax^.fext = 6 then { FSINCOS } begin appendreg(2,saveeax^.sincosreg); s := s + ':'; end; appendreg(2,saveeax^.fry); end; end else if eax^.fopclas = 3 then { dest is } begin { FMor ((mode1 = 7) and (reg1 >= 2)) then escape(0); { An, PC modes, Imm } dumpea(mode1,reg1,eax,1); end; end; 2,3: { Revearse assemble FBF *+2 as FNOP } if (insr.instp^.fpredicate = 0) and (mode2 = 2) and (eax^.exoffword = 0)OVE from MC68881 } s := 'FMOVE'; appendfloatsize(eax^.frx); appendreg(2,eax^.fry); if mode1 = 0 {Dreg} then if eax^.frx in [2,3,5,7] then escape(0); if (mode1 = 1) or ((mode1 = 7) and (reg1 > 1)) then escape(0); saveeax := eax;  then begin { FNOP } eax := addr(eax^,2); s := 'FNOP'; end else { FBcc } begin if insr.instp^.fpredicate = 15 {FBT} then s := 'FBRA' else begin s := 'FB'; appendfloatcondition(insr.i eax := addr(eax^,2);comma; dumpea(mode1,reg1,eax,0); if saveeax^.frx = 3 {size P} then strwrite(s,strlen(s)+1,i,'{#',saveeax^.Kfactor:1,'}') else if saveeax^.frx = 7 {size P} then begin if saveeax^.zeros <> 0 then escape(0); nstp^.fpredicate); end; if mode2 = 3 then begin s := s + '.L'; j := eax^.exofflong; eax := addr(eax^,4); end else begin j := eax^.exoffword; eax := addr(eax^,2); end; j := j + 2; s := s + ' *';  strwrite(s,strlen(s)+1,i,'{D',saveeax^.KDreg:1,'}'); end; end else escape(0); end else case mode2 of 1: { FScc, FDBcc, FTRAPcc } begin if mode1 = 1 then s := 'FDB' else if (mode1 = 7) and (reg1 = 4) then s := ' if j >= 0 then s := s + '+'; strwrite(s,strlen(s)+1,i,j:1); end; 4,5: { FSAVE, FRESTORE } begin if mode2 = 4 then begin if (mode1 = 0) or (mode1 = 1) or (mode1 = 3) or ((mode1 = 7) and (reg1 >= 2)) t1     cord case integer of 1: (the_op : byte; which : 0..7; mode_16 : 0..3; reg_ax : 0..7); 2: (w : UWORD); end; { move16_type } type my_word = packed record case integer of 1: (nib1,nib2 : 0..15; byte_it : byte); 2: (w : WORD); /89 JWH : } procedure cinv_cpush; { Handle '040 CINV and CPUSH instructions } type cache_40_type = packed record case integer of 1: (the_op : byte; which_caches : 0..3; which_instr : 0..1; scope : 0..3; reg_ax : 0..7); 2: (w : UW end; { my_word type } var see_it : move16_type; var see_ex : my_word; begin see_it.w := INSR.INSTP^.IWORD; { see it as a move16 } { So far we've examined only the first 7 bits of the instruction } s := 'MOVE16 '; witORD); end; { cache_40_type } var see_it : cache_40_type; begin see_it.w := INSR.INSTP^.IWORD; { see it as a cinv or cpush } { So far we've examined only the first 7 bits of the instruction } with see_it do begin if the_op h see_it do begin if the_op <> hex('F6') { $F6 } then escape(0); { First 8 bits } if which > 1 then escape(0); { First 11 bits } if which = 1 then { have post increment format } begin if mode_16 <> 0 then { gotta be for this format } e<> hex('F4') then escape(0); { First 8 bits } if which_instr = 0 then begin { CINV } case scope of 0 : escape(0); { ILLEGAL } 1 : s := 'CINVL '; 2 : s := 'CINVP '; 3 : s := 'CINVA '; otherwise ; end; { case } case which_caches scape(0); { First 13 bits } if eax^.exDAbit <> TRUE { 1 } then { gotta be for this format } escape(0); { First 17 bits } see_ex.w := eax^.exoffword; if ((see_ex.nib2 <> 0) or (see_ex.byte_it <> 0)) then escape(0); { All 32 bits checkeof 0 : s := s + 'NONE'; { NOOP, NOT ILLEGAL } 1 : s := s + 'DC'; 2 : s := s + 'IC'; 3 : s := s + 'DC/IC'; otherwise ; end; { case } if ((scope = 1) or (scope = 2)) then { CINVL or CINVP .. } begin { get the reg ... } comma; s := d out } s := s + '('; APPENDREG(1,reg_ax); s := s + ')'; s := s + '+'; { emitpostincr(reg_ax); } comma; s := s + '('; APPENDREG(1,EAX^.EXREG); s := s + ')'; s := s + '+'; { emitpostincr(ext.exRn1); } end { which = 1 , post increment fors + '('; APPENDREG(1,reg_ax); s := s + ')'; end; { CINVL or CINVP } end { CINV } else begin { CPUSH } case scope of 0 : escape(0); { ILLEGAL } 1 : s := 'CPUSHL '; 2 : s := 'CPUSHP '; 3 : s := 'CPUSHA '; otherwise ; end; { casmat } else { which = 0, have absolute format } begin { All 48 bits fit the format at this point ... } case mode_16 of 0 : begin s := s + '('; APPENDREG(1,reg_ax); s := s + ')'; s := s + '+'; comma; DUMPEA(7,1,EAX,4); end; 1 : e } case which_caches of 0 : s := s + 'NONE'; { NOOP, NOT ILLEGAL } 1 : s := s + 'DC'; 2 : s := s + 'IC'; 3 : s := s + 'DC/IC'; otherwise ; end; { case } if ((scope = 1) or (scope = 2)) then { CPUSHL or CPUSHP .. } begin { get the begin DUMPEA(7,1,EAX,4); comma; s := s + '('; APPENDREG(1,reg_ax); s := s + ')'; s := s + '+'; end; 2 : begin s := s + '('; APPENDREG(1,reg_ax); s := s + ')'; comma; DUMPEA(7,1,EAX,4); end; 3 : begin DUMPEA(7,1,EAX,4); comregister ... } comma; s := s + '('; APPENDREG(1,reg_ax); s := s + ')'; end; { CPUSHL or CPUSHP } end; { CPUSH } end; { with see_it } done := TRUE; end; { cinv_cpush } {************************************************************ma; s := s + '('; APPENDREG(1,reg_ax); s := s + ')'; end; otherwise ; { this really can't happen } end; { case } end; { which = 0, absolute format } end; { with see_it } done := TRUE; end; { move16 } { Added 12/24} {************************************************************} BEGIN { REV ASM } INSR.INSTI:=INSP; EAX := ADDR(INSR.INSTP^,2); original_eax := eax; SETSTRLEN(S,0); WITH INSR.INSTP^ DO TRY MODE1:=IMODE1; MODE2:=IMODE2; RE1     2:1); DONE := TRUE; END; 7:BEGIN STRWRITE(S,STRLEN(S),I,BYTE1:1,',D',REG2:1); DONE:=TRUE; END; 8:BEGIN { OPCODE 0 } IF BIT8 AND (MODE1=1) THEN BEGIN { MOVEP } S := 'MOVEP'; SUFFIX(ORD(BIT6)+1); IF BIT7 THEN se escape(0); end; strwrite(s,strlen(s)+1,i,eax^.exDc:1,',','D',eax^.exDu:1,','); eax := addr(eax^,2); opc := 19; end else if (opsize = 3) and (reg2 < 3) then {CHK2 CMP2} begin m1m3m4check; if (mode1 = 0) or ((mode1 = 7) BEGIN APPENDREG(0,REG2); COMMA; APPEND_INT(EAX^.EXOFFWORD); STRWRITE(S,STRLEN(S)+1,I,'(A',SREG(REG1),')'); END ELSE STRWRITE(S,STRLEN(S)+1,I,EAX^.EXOFFWORD:1, '(A',SREG(REG1),'),D',SREG(REG2)); EAX := AD and (reg1 = 4)) then escape(0); if eax^.exwlbit then s := 'CHK2' else s := 'CMP2'; case reg2 of 0: s := s + '.B '; 1: s := s + '.W '; 2: s := s + '.L '; end; saveeax := eax; eax := addr(eax^,2); DUMG1:=IREG1; REG2:=IREG2; I:=1; DONE := FALSE; WHILE IAND(IWORD,OPMASKS[I])<>OPBITS[I] DO I := I + 1; OPC :=OPCTRL[I]; S := OPNAMES[I]; OSIZE:=OPSIZE; REPEAT CASE OPC OF 0:DONE:=TRUE; {NO OPERANDS} 1:BEGIN { MOVE.BDR(EAX^,2); { SKIP THE OFFSET } END { MOVEP } ELSE BEGIN IF BIT8 OR (REG2=4) THEN BEGIN { BTST, BCHG, BCLR, BSET } if mode1 = 1 then escape(0); if mode1 = 7 then if osize = 0 { BTST } then be .W .L } M7R4CHECK; IF MODE2=7 THEN IF REG2>1 THEN ESCAPE(0); IF OPCODE=1 THEN begin if mode1 = 1 {An} then escape(0); OSIZE:=0; end ELSE IF OPCODE=2 THEN OSIZE:=2 ELSE OSIZE:=1; DUMPEA(MODE1,REG1,EAX,OSIZE); COMMgin if not bit8 and (reg1 > 3) then escape(0); end else if reg1 > 1 then escape(0); S := STR(BITTYPE,OSIZE*4+1,4); IF BIT8 THEN { BIT # IS IN D REG } BEGIN BLANK; APPENDREG(0,REG2); COMMA; END ELSE BEGIN A; DUMPEA(MODE2,REG2,EAX,OSIZE); DONE := TRUE; END; 2:IF MODE2=1 THEN ESCAPE(0) ELSE OPC:=1; { MOVE.B } 3:BEGIN {JMP OR JSR} IF (MODE1=2) OR (MODE1>4) THEN BEGIN IF (MODE1=7) AND (REG1>3) THEN ESCAPE(0); END ELSE ESCAPE(0);  { BIT # IS IMMEDIATE } K := EAX^.EXB1; IF MODE1=0 THEN K := K MOD 32 ELSE K := K MOD 8; BLANK; NUMBERSIGN; APPEND_INT(K); COMMA; EAX := ADDR(EAX^,2); END; OPC:=19; END { BIT OPS } ELSE if bit11 and (opsize=3) then {  OPC:=19; END; 4:BEGIN { STOP, RTD } STRWRITE(S,STRLEN(S),I,EAX^.EXOFFWORD:1); EAX := ADDR(EAX^,2); DONE := TRUE; END; 5:BEGIN { REG IS ONLY ARG } S := S+SREG(REG1); DONE := TRUE; END; 6:BEGIN {Bcc, BRA, BSR} J := CAS, CAS2 } if (mode1 = 7) and (reg1 = 4) then { CAS2 } begin eaxplus2 := addr(eax^,2); case reg2 of 5: s := 'CAS2.B'; 6: s := 'CAS2.W'; 7: s := 'CAS2.L'; otherwise escape(0); end; strwrite(s,strlen(s)+1,i, ' D',eax^.HEX1 * 2 + 1; S[2]:=BRATYPE[J]; S[3]:=BRATYPE[J+1]; if byte1 = -1 then {32 bit disp} begin j := eax^.exofflong; eax := addr(eax^,4); s := s + '.L'; end else IF BYTE1<>0 THEN BEGIN J := BYTE1; S := S + '.S'; END ELSexDc:1,':D',eaxplus2^.exDc:1, ',D',eax^.exDu:1,':D',eaxplus2^.exDu:1,',('); if eax^.exdabit then s := s + 'A' else s := s + 'D'; strwrite(s,strlen(s)+1,i,eax^.exreg:1,'):('); if eaxplus2^.exdabit then s := s + 'A' else s := s + 'D'E BEGIN J := EAX^.EXOFFWORD; EAX := ADDR(EAX^,2); END; S := S + ' *'; IF J>=(-2) THEN S := S + '+'; if j = maxint then s := s + '2147483649' else if j = maxint-1 then s := s + '2147483648' else STRWRITE(S,STRLEN(S)+1,I,J+; strwrite(s,strlen(s)+1,i,eaxplus2^.exreg:1,')'); eax := addr(eax^,4); end else { CAS } begin m1m7r1check; if mode1 = 0 {Dn} then escape(0); case reg2 of 5: s := 'CAS.B D'; 6: s := 'CAS.W D'; 7: s := 'CAS.L D'; otherwi2     PEA(MODE1,REG1,EAX,0); comma; if saveeax^.exdabit then s := s + 'A' else s := s + 'D'; strwrite(s,strlen(s)+1,i,saveeax^.exreg:1); end else BEGIN CASE HEX1 OF 0,2,10: BEGIN { ORI, ANDI, EORI } dr(eax^,2); DUMPEA(MODE1,REG1,EAX,OSIZE); COMMA; APPENDREG(I,J); END; END; OTHERWISE ESCAPE(0) { INVALID INSTRUCTION } END; END; END; DONE:=(OPC=8); END; 9:BEGIN { OPCODE 4 } IF BIT8 THEN BEGIN  IF HEX1=0 THEN S := 'ORI' ELSE IF HEX1=2 THEN S := 'ANDI' ELSE IF HEX1=10 THEN S := 'EORI'; IF (MODE1=7) AND (REG1=4) THEN BEGIN { op to CCR or SR } IF OSIZE>1 THEN ESCAPE(0); BLANK; IF HEX2=3 THEN  { CHK, LEA, EXTB } IF (OSIZE=2) or (osize = 0) THEN BEGIN { CHK } IF MODE1=1 THEN ESCAPE(0); if mode2 = 6 then begin S := 'CHK.W '; DUMPEA(MODE1,REG1,EAX,1); end else if mode2 = 4 then begin s := 'CHK.begin dumpea(7,4,eax,0); S := S + ',CCR'; end ELSE begin dumpea(7,4,eax,1); S := S + ',SR'; end; END ELSE BEGIN M1M7R1CHECK; IF OSIZE=3 THEN ESCAPE(0); S := S + '.' + STR(SSIL '; DUMPEA(MODE1,REG1,EAX,2); end else escape(0); COMMA; APPENDREG(0,REG2); END else if mode1 = 0 then { EXTB } begin s := 'EXTB.L '; appendreg(0,reg1); end else if mode2 = 7 then BEGINZE,OSIZE+1,1); BLANK; OPC:=20; END; END; 4,6: if opsize = 3 then { RTM, CALLM } if mode1 <= 1 then { RTM } begin if mode1 = 0 then s := 'RTM D' else s := 'RTM A'; strwrite(s,strlen(s)+1,i,reg1:1 { LEA } IF (MODE1<2) OR (MODE1=3) OR (MODE1=4) OR ((MODE1=7) AND (REG1>3)) THEN ESCAPE(0); S := 'LEA '; DUMPEA(MODE1,REG1,EAX,2); COMMA; APPENDREG(1,REG2); END else escape(0); END { CHK , LEA } ELSE CASE HEX1 OF ); end else { CALLM } begin m1m3m4m7r4check; if (mode1 = 0) then escape(0); s := 'CALLM #'; strwrite(s,strlen(s)+1,i,eax^.exb1:1); comma; eax := addr(eax^,2); opc := 19 0: BEGIN M1M7R1CHECK; IF OSIZE=3 THEN S := 'MOVE SR,' ELSE S := 'NEGX.'+STR(SSIZE,OSIZE+1,1)+' '; OPC:=18; END; 2: BEGIN M1M7R1CHECK; IF OSIZE=3 THEN BEGIN { MOVE from CCR } S:='MOVE CCR; end else BEGIN { ADDI, SUBI } M1M7R1CHECK; IF OSIZE=3 THEN ESCAPE(0); IF HEX1=4 THEN S := 'SUBI.' ELSE S := 'ADDI.'; S := S + STR(SSIZE,OSIZE+1,1); BLANK; OPC:=20; END; 12:BEGIN ,';DUMPEA(MODE1,REG1,EAX,1); END ELSE BEGIN { CLR } S := 'CLR.'+STR(SSIZE,OSIZE+1,1); BLANK; OPC:=18; END; END; 4: BEGIN IF MODE1=1 THEN ESCAPE(0); IF OSIZE=3 THEN BEGIN { MOVE TO CCR{CMPI} if (mode1 = 1) or ((mode1 = 7) and (reg1 = 4)) then escape(0); IF OSIZE=3 THEN ESCAPE(0); STRWRITE(S,1,I,'CMPI.',SSIZE[OSIZE+1]); BLANK; OPC:=20; END; 14:BEGIN {MOVES} M7R1CHECK; IF (MODE1<2) OR (OSIZE=3) THEN ESCAPE } S := 'MOVE '; DUMPEA(MODE1,REG1,EAX,1); S := S + ',CCR'; END ELSE BEGIN { NEG } M7R1CHECK; S := 'NEG.'+STR(SSIZE,OSIZE+1,1); BLANK; OPC:=18; END; END; 6: BEGIN IF MODE1=1 THEN ESCAPE(0); (0); STRWRITE(S,1,I,'MOVES.',SSIZE[OSIZE+1]); BLANK; I:=ORD(EAX^.EXDABIT); J:=ORD(EAX^.EXREG); IF EAX^.EXWLBIT THEN BEGIN XREG(EAX^); COMMA; EAX:=ADDR(EAX^,2); DUMPEA(MODE1,REG1,EAX,OSIZE); END ELSE BEGIN eax := ad IF OSIZE=3 THEN BEGIN { MOVE TO SR } S := 'MOVE '; DUMPEA(MODE1,REG1,EAX,1); S := S + ',SR'; END ELSE BEGIN { NOT } M7R1CHECK; S := 'NOT.'+STR(SSIZE,OSIZE+1,1); BLANK; OPC:=18; END; E2     E(0); S:='MOVEM'; SUFFIX(ORD(BIT6)+1); EAX := ADDR(EAX^,2); DUMPEA(MODE1,REG1,EAX,2); COMMA; INSR.INSTP := ADDR(INSR.INSTP^,2); DUMPREGBITS(INSR.INSTP^,FALSE); END else if bit6 then {DIVS.L DIVU.L}  { CASE HEX1 } DONE:=(OPC=9); END; { OPCODE 4 } 10:if (hex2 = 15) and bit3 and (reg1 in [2,3,4]) then { TRAPcc } begin case hex1 of 0: s := 'TRAPT'; 1: s := 'TRAPF'; 2: s := 'TRAPHI'; 3: s := 'TRAPLS'; 4: s := 'TRA begin m1m7r4check; if eax^.exwlbit then s := 'DIVS' else s := 'DIVU'; if eax^.exscale = 2 then s := s + '.L ' else if eax^.exreg = eax^.exoffbyte then s := s + '.L ' else s := s + 'L.L '; PCC'; 5: s := 'TRAPCS'; 6: s := 'TRAPNE'; 7: s := 'TRAPEQ'; 8: s := 'TRAPVC'; 9: s := 'TRAPVS'; 10: s := 'TRAPPL'; 11: s := 'TRAPMI'; 12: s := 'TRAPGE'; 13: s := 'TRAPLT'; 14: s := 'TRAPGT'; 15: s := 'ND; 8: BEGIN IF BIT7 THEN BEGIN { MOVEM TO EA or EXT.W or EXT.L } IF MODE1=0 THEN BEGIN s := 'EXT'; SUFFIX(ORD(BIT6)+1); BLANK; APPENDREG(0,REG1); END ELSE BEGIN { MOVEM TO EA } M7R1CHECK; IF (MODE1<2) OR (MOsaveeax := eax; eax := addr(eax^,2); dumpea(mode1,reg1,eax,2); comma; if (saveeax^.exreg <> saveeax^.exoffbyte) or (saveeax^.exscale = 2) then begin appendreg(0,saveeax^.exoffbyte); s := s + ':'; end; DE1=3) THEN ESCAPE(0); S:='MOVEM'; SUFFIX(ORD(BIT6)+1); DUMPREGBITS(EAX^,MODE1=4); EAX := ADDR(EAX^,2); COMMA; OPC:=19; END; END ELSE if (hex2 = 0) and bit3 then {LINK.L} begin strwrite(s,1,i,'LINK.L A', appendreg(0,saveeax^.exreg); end else {MULS or MULU} begin m1m7r4check; if eax^.exwlbit then s := 'MULS.L ' else s := 'MULU.L '; saveeax := eax; eax := addr(eax^,2); dumpea(mode1,reg1reg1:1,',#',eax^.exofflong:1); eax := addr(eax^,4); end else IF OSIZE=0 THEN BEGIN { NBCD } M1M7R1CHECK; S := 'NBCD '; OPC:=19; END ELSE if mode1 = 1 then {BKPT} begin s := 'BKPT #'; ,eax,2); comma; if saveeax^.exscale = 2 then begin appendreg(0,saveeax^.exoffbyte); s := s + ':' end; appendreg(0,saveeax^.exreg); end; 14:BEGIN CASE HEX2 OF 4: STRWRITE(S,1,I,'TRAP #',HEX3:1); strwrite(s,strlen(s)+1,i,reg1:1); end else BEGIN IF MODE1=0 THEN S := 'SWAP D'+SREG(REG1) ELSE BEGIN { PEA } IF (MODE1<2) OR (MODE1=3) OR (MODE1=4) OR ((MODE1=7) AND (REG1>3)) THEN ESCAPE(0); S := 'PE 5: BEGIN IF BIT3 THEN STRWRITE(S,1,I,'UNLK A',REG1:1) ELSE BEGIN STRWRITE(S,1,I,'LINK.W A',REG1:1,',#',EAX^.EXOFFWORD:1); EAX := ADDR(EAX^,2); END; END; 6: BEGIN {MOVE USP,.. or MOVE ..,USP} A '; DUMPEA(MODE1,REG1,EAX,2); END; END; END; 10:if iword = hex('4AFC') then s := 'ILLEGAL' else BEGIN { TST, TAS } if osize = 3 {TAS} then M1M7R1CHECK; if osize = 0 {TST.B} then if mode1 = 1 then IF BIT3 THEN S := 'MOVE USP,A' + SREG(REG1) ELSE S := 'MOVE A'+ SREG(REG1) + ',USP'; END; 7: BEGIN {MOVEC} S:='MOVEC '; IF HEX3=11 THEN BEGIN XREG(EAX^); COMMA; CREG(EAX^); END ELSE IF HEX3=10 THEN BEGI escape(0); IF OSIZE=3 THEN S := 'TAS ' ELSE S := 'TST.' + STR(SSIZE,OSIZE+1,1) + ' '; OPC:=19; END; 12:if bit7 then BEGIN { MOVEM EA TO REGS } IF (MODE1<2) OR (MODE1=4) OR ((MODE1=7) AND (REG1>3)) THEN ESCAPN CREG(EAX^); COMMA; XREG(EAX^); END ELSE ESCAPE(0); EAX:=ADDR(EAX^,2); END; OTHERWISE ESCAPE(0) { INVALID INSTRUCTION } END; { CASE HEX2 } END; OTHERWISE ESCAPE(0) { INVALID INSTRUCTION } END;3     TRAPLE'; end; if reg1 = 2 then { .W } begin strwrite(s,strlen(s)+1,i,'.W #',eax^.exoffword:1); eax := addr(eax^,2); end else if reg1 = 3 then { .L } begin strwrite(s,strlen(s)+1,i,'.L #',eax^.exofflong:1); eax :=',reg1:1,'),-(A',reg2:1, '),#',eax^.exoffword:1); eax := addr(eax^,2); end ELSE BEGIN { OR } S := 'OR.' + STR(SSIZE,OSIZE+1,1); BLANK; IF BIT8 THEN BEGIN M7R1CHECK; OPC:=22; END ELSE BEGIN M1M7R4CHECK; OPC:=2 addr(eax^,4); end; done := true; end else BEGIN { ADDQ or SUBQ or Scc or DBcc } IF OSIZE=3 THEN BEGIN J := HEX1 * 2 + 1; IF MODE1=1 THEN BEGIN if j = 1 then STRWRITE(S,1,I,'DBT D',REG1:1,',*') else 1; END; END; DONE:=(OPC=11); END; 12:BEGIN { SUB , SUBA or SUBX } IF OSIZE=3 THEN BEGIN M7R4CHECK; S:='SUBA'; SUFFIX(ORD(BIT8)+1); DUMPEA(MODE1,REG1,EAX,OPSIZE1); COMMA; APPENDREG(1,REG2); END ELSE IF BIT8 AND (MODEif j = 3 then STRWRITE(S,1,I,'DBRA D',REG1:1,',*') else STRWRITE(S,1,I,'DB',STR(CCTYPE,J,2),' D',REG1:1,',*'); K := EAX^.EXOFFWORD; k := k +2; { avoid 16 bit math } EAX := ADDR(EAX^,2); IF K>=0 THEN S := S + '+'; 1<2) THEN BEGIN { SUBX } S := 'SUBX.'+STR(SSIZE,OSIZE+1,1); IF BIT3 THEN STRWRITE(S,STRLEN(S)+1,I,' -(A',REG1:1,'),-(A',REG2:1,')') ELSE STRWRITE(S,STRLEN(S)+1,I,' D',REG1:1,',D',REG2:1); END ELSE BEGIN  STRWRITE(S,STRLEN(S)+1,I,K:1); END ELSE BEGIN M7R1CHECK; S:='S '; if j = 1 then s := 'ST ' else if j = 3 then s := 'SF ' else STRWRITE(S,2,I,STR(CCTYPE,J,2)); OPC:=19; END; END  { SUB } S := 'SUB.'+STR(SSIZE,OSIZE+1,1); BLANK; IF BIT8 THEN BEGIN { DESTINATION IS } M7R1CHECK; IF (MODE1<2) THEN ESCAPE(0); OPC:=22; END ELSE BEGIN IF (OSIZE=0) AND (MODE1=1) THEN ESC ELSE BEGIN IF (MODE1=1) AND (OSIZE=0) THEN ESCAPE(0); M7R1CHECK; IF BIT8 THEN S := 'SUBQ.' ELSE S := 'ADDQ.'; J := DATA; IF J=0 THEN J:=8; STRWRITE(S,STRLEN(S)+1,I,SSIZE[OSIZE+1],' #',J:1,','); OPC:=18; END; DONEAPE(0); OPC:=21; END; END; DONE:=(OPC=12); END; 13:BEGIN { CMP ,CMPA, CMPM, EOR } IF OSIZE=3 THEN BEGIN { CMPA } S := 'CMPA'; SUFFIX(ORD(BIT8)+1); DUMPEA(MODE1,REG1,EAX,ORD(BIT8)+1); COMMA; APPENDREG(1,REG:=(OPC=10); END; 11:BEGIN { OR DIVU DIVS SBCD } IF (MODE2=3) OR (MODE2=7) THEN BEGIN { DIVU or DIVS } M1M7R4CHECK; IF MODE2=3 THEN S := 'DIVU.W ' ELSE S := 'DIVS.W '; DUMPEA(MODE1,REG1,EAX,1); COMMA; APPENDREG(0,REG2); 2); END ELSE BEGIN IF BIT8 THEN BEGIN IF MODE1=1 THEN S := 'CMPM.' + STR(SSIZE,OSIZE+1,1) + ' (A' + SREG(REG1) + ')+,(A' + SREG(REG2) + ')+' ELSE BEGIN { EOR } M7R1CHECK; S := 'EOR.' + STR(SSIZE, END ELSE IF bit8 AND (MODE1<2) THEN if mode2 = 4 then BEGIN { SBCD } IF BIT3 THEN STRWRITE(S,1,I,'SBCD -(A',REG1:1,'),-(A',REG2:1,')') ELSE STRWRITE(S,1,I,'SBCD D',REG1:1,',D',REG2:1) END else { PACK UNPKOSIZE+1,1); BLANK; OPC:=22; END; END ELSE BEGIN { CMP } IF (MODE1=1) AND (MODE2=0) THEN ESCAPE(0); S := 'CMP.' + STR(SSIZE,MODE2+1,1); BLANK; DUMPEA(MODE1,REG1,EAX,MODE2); COMMA; APPENDREG(0,REG2); } begin if mode2 = 5 then s := 'PACK ' else s := 'UNPK '; if mode1 = 0 then { D reg } strwrite(s,strlen(s)+1,i,'D',reg1:1,',D',reg2:1, ',#',eax^.exoffword:1) else { -(A reg) } strwrite(s,strlen(s)+1,i,'-(A END; END; DONE:=(OPC=13); END; 14:BEGIN { AND, MULU, MULS, ABCD } { EXG } IF (MODE2=3) OR (MODE2=7) THEN BEGIN { MULU or MULS } M1M7R4CHECK; IF MODE2=3 THEN S := 'MULU.W ' ELS3     F (OSIZE=0) AND (MODE1=1) THEN ESCAPE(0); OPC:=21; END; END; DONE:=(OPC=15); END; 16:if bit11 and bit7 and bit6 then {bit field instr} begin case hex1 of 8: begin m1m3m4m7r4check; s := 'BFTST '; end; 9: begin mE); COMMA; OPC:=19; END; 21:BEGIN DUMPEA(MODE1,REG1,EAX,OSIZE); COMMA; APPENDREG(0,REG2); DONE:=TRUE; END; 22:BEGIN APPENDREG(0,REG2); COMMA; OPC:=18; END; 23: { opcode $F } begin if reg2 = 1 then mc68881 { Next two li1m3m4m7r4check; s := 'BFEXTU '; end; 10: begin m1m3m4m7r1check; s := 'BFCHG '; end; 11: begin m1m3m4m7r4check; s := 'BFEXTS '; end; 12: begin m1m3m4m7r1check; s := 'BFCLR '; end; 13: begin m1m3m4m7r4check; s := 'BFFFO '; end; nes JWH 12/24/89 : } else if reg2 = 2 then cinv_cpush else if (reg2 = 3) then move16 else begin s := ''; done := true; end; end; OTHERWISE S :=''; DONE:=TRUE; END; { CASE OPC } UNTIL DONE; RECOVER E S := 'MULS.W '; DUMPEA(MODE1,REG1,EAX,1); COMMA; APPENDREG(0,REG2); END ELSE IF (MODE2=4) AND (MODE1<2) THEN BEGIN { ABCD } IF BIT3 THEN STRWRITE(S,1,I,'ABCD -(A',REG1:1,'),-(A',REG2:1,')') ELSE STRWRITE(S,14: begin m1m3m4m7r1check; s := 'BFSET '; end; 15: begin m1m3m4m7r1check; s := 'BFINS '; end; end; saveeax := eax; eax := addr(eax^,2); if hex1 = 15 then begin bfreg; comma; end; dumpea(mode1,reg1,eax,1); 1,I,'ABCD D',REG1:1,',D',REG2:1) END ELSE IF (MODE2=6) AND (MODE1=1) THEN STRWRITE(S,1,I,'EXG D',REG2:1,',A',REG1:1) ELSE IF (MODE2=5) AND (MODE1=0) THEN STRWRITE(S,1,I,'EXG D',REG2:1,',D',REG1:1) ELSE IF (MODE2=5) AND (MOD offset_width; if hex1 in [9,11,13] then begin comma; bfreg; end; done := true; end else BEGIN { SHIFT / ROTATE } IF OSIZE=3 THEN BEGIN { MEMORY OPERAND } IF BIT11 THEN ESCAPE(0); M7R1E1=1) THEN STRWRITE(S,1,I,'EXG A',REG2:1,',A',REG1:1) ELSE BEGIN { AND } S := 'AND.' + STR(SSIZE,OSIZE+1,1); BLANK; IF BIT8 THEN BEGIN M7R1CHECK; IF (MODE1<2) THEN ESCAPE(0); OPC:=22; END ELSE BECHECK; IF (MODE1<2) THEN ESCAPE(0); S := STR(SRTYPE,REG2*4+1,3); IF REG2<>2 THEN SETSTRLEN(S,2); { IF NOT ROX, THEN ONLY 2 } IF BIT8 THEN S := S + 'L ' { ADD DIRECTION } ELSE S := S + 'R '; OPC:=19; END ELSEGIN M1M7R4CHECK; OPC:=21; END; END; DONE:=(OPC=14); END; 15: BEGIN { ADD , ADDA or ADDX } IF OSIZE=3 THEN BEGIN M7R4CHECK; S := 'ADDA'; SUFFIX(ORD(BIT8)+1); DUMPEA(MODE1,REG1,EAX,OPSIZE1); COMMA; APPENDREG(1,REG2 BEGIN { REGISTER OPERAND } I := MODE1 MOD 4; { IGNORE BIT 5 } S := STR(SRTYPE,I*4+1,3); IF I<>2 THEN SETSTRLEN(S,2); { IF NOT ROX, THEN ONLY 2 } IF BIT8 THEN S := S + 'L.' { ADD DIRECTION } ELSE S := S + 'R.';); END ELSE IF BIT8 AND (MODE1<2) THEN BEGIN { ADDX } S := 'ADDX.'+STR(SSIZE,OSIZE+1,1); IF BIT3 THEN STRWRITE(S,STRLEN(S)+1,I,' -(A',REG1:1,'),-(A',REG2:1,')') ELSE STRWRITE(S,STRLEN(S)+1,I,' D',REG1:1,',D', S := S + STR(SSIZE,OSIZE+1,1); BLANK; { ADD SIZE } IF BIT5 THEN APPENDREG(0,REG2) { REGISTER OR COUNT } ELSE BEGIN IF REG2=0 THEN K:=8 ELSE K:=REG2; NUMBERSIGN; APPEND_INT(K); END; OPC:=17; REG2:1); END ELSE BEGIN { ADD } S := 'ADD.'+STR(SSIZE,OSIZE+1,1); BLANK; IF BIT8 THEN BEGIN { DESTINATION IS } M7R1CHECK; IF (MODE1<2) THEN ESCAPE(0); OPC:=22; END ELSE BEGIN I END; DONE:= (OPC=16); END; 17:BEGIN COMMA; APPENDREG(0,REG1); DONE:=TRUE; END; 18:BEGIN DUMPEA(MODE1,REG1,EAX,OSIZE); DONE:=TRUE; END; 19:BEGIN DUMPEA(MODE1,REG1,EAX,0); DONE:=TRUE; END; 20:BEGIN DUMPEA(7,4,EAX,OSIZ4     BEGIN IF ESCAPECODE=0 THEN begin S := ''; eax := original_eax; { advance 2 bytes for illegal instr } end {ELSE ESCAPE(ESCAPECODE)}; END; NXTP := ORD(EAX); END; { REVASM } END. { MODULE REVASM_MOD }  SAVE STATUS REG (scs) MOVE #$2700,SR BLOCK INTERUPTS MOVE.B DSTATUS2,D7 SAVE CURRENT RUNFLAG BSET #RUNFLAG,DSTATUS2 NOW RUNNING (rdq) MOVE.L 16(A6),D0 GET OPCODE TST.L D0 RANGE* DEBUGGER FOR PASCAL PRODUCT * * SYSTEM INTERFACE * * rdq JAN 82 rdq scs SEP 82 rdq SEP 84 * * SEP 84 changes made to allow operation in 32 bit address space * * CHANGES MARKED BY CHG32 * COPYRIGHT (C) 1984 HEWLETT-PACKARD CO. 1.0 NOSYMS SPR CHECK IT BMI.S BADOPCODE CMPI.L #8,D0 MAX VALUE (rdq) BGT.S BADOPCODE ASL.L #2,D0 * 4 LEA DBUGOPS,A0 GET EXECUTE ADDRESS MOVEA.L 0(A0,D0),A0 JMP (A0) DBUGOPS DC.L DBUGINIT 0 POWINT * DEF REALDEBUGGER * REFA LOADER,sysglobals (scs) REFA ASM_NEWWORDS REFA SYSBUG_CALLSYSCODE REFA ASM_CACHE_OFF,ASM_FLUSH_ICACHE,ASM_ICACHE_OFF CHG32 REFA ASM_CACHE_MODE LMODE SYSBUG_CALLSYSCODE,ASM_NEER ON INITIALIZE DC.L DBUGSPRG 1 PROGRAM STARTING DC.L DBUGEPRG 2 PROGRAM ENDED DC.L DBUGKBD 3 CALL FROM KEYBOARD ISR DC.L DBUGIPLT 4 IMPLANT CALL FROM SYSTEM/USER DC.L DBUGLNUM 5 SYS WANTS LAST LINE # DC.L WWORDS LMODE ASM_CACHE_OFF,ASM_FLUSH_ICACHE,ASM_ICACHE_OFF CHG32 LMODE ASM_CACHE_MODE * T15OP EQU $4E4F JMPOP EQU $4EF9 RTSOP EQU $4E75 SYSFLAG2 EQU $FFFFFEDA E@DIV EQU $3242 BOOT ROM LOCATIONS E@MPY EQU $31A6 B DBUGPAUSE 6 NON ISR WANTS PAUSE DC.L DBUGRESET 7 RESET KEY HOOK (rdq) DC.L DBISRIPLT 8 IMPLANT CALL FROM ISR BADOPCODE EQU * * DEBUGXIT EQU * BCLR #1,DSTATUS CLEAR WAIT FLAG DEBUGXIT2 EQU * BTST #RUUS_ERRORV EQU $FFFFFFFA GLOBALBASE EQU LOADER-66 PROGRAM GLOBAL BASE RBASEPTR EQU LOADER-50 PROGRAM RELOCATION BASE SYSDEFS EQU LOADER-70 SYSTEM SYMBOL TABLE escapecode equ sysglobals-2 (scs) recoverNFLAG,D7 BNE.S DEBUGXITX (rdq) BCLR #RUNFLAG,DSTATUS2 (rdq) DEBUGXITX move -4(a6),d0 GET CALLERS SR (scs) unlk a6 blk equ sysglobals-10 (scs) ioresult equ sysglobals-22 (scs) DEFADDR EQU 6 DEFSIZE EQU 10 RUNFLAG EQU 1 (rdq) * * PROCEDURE DEBUGGER(OP:INTEGER; P1,P2:INTEGER); * * S (scs) MOVEA.L (SP)+,A0 GET RETURN ADDRESS ADDA.L #12,SP POP ARGS move d0,sr restore caller's status register (scs) JMP (A0) TTL INITIALIZE DEBUGGER VARIABLES PAGE DBUGP+12 OP A6+16 * SP+8 P1 A6+12 * SP+4 P2 A6+8 * SP RETURN A6+4 * A6 * SR DC.W 0 DUMMY PROC INFO REALDEBUGGER EQU * movem.l (sp)+,a0-a3 return address, parameters (scsINIT EQU * INITIALIZE DEBUGGER VARIABLES MOVE.L #HIBUGRAM,D0 CLEAR CONTROL VARIABLES SUB.L #LTFLAGS,D0 LSR.W #2,D0 DIV 4 LEA LTFLAGS,A0 MOVEQ #0,D1 DBGINIT0 MOVE.L D1,(A0)+ DBRA D0,DBGINIT0 * * ALLOW 64 ENTRIES IN TR) trap #11 move into supervisor mode (scs) move (sp)+,d0 user's status register (scs) movem.l a0-a3,-(sp) push paramters, return address (scs) LINK A6,#-4 GET LOCAL SPACE move d0,-4(a6) ACE QUEUE * PEA QSTART GET SPACE FROM HEAP MOVE.L #128,-(SP) QUEUE BUFFER FOR 64 LINES JSR ASM_NEWWORDS MOVEA.L QSTART,A0 MOVE.L A0,QLAST LEA 256(A0),A0 MOVE.L A0,QEND * * INITIALIZE INPUT STACK AREA JWS 6/12/85 *4      MOVE.W #RTSOP,SYMBOLHOOK NO_OP SYMBOL TABLE HOOK PEA UEXCPI ERROR TRAP COMMAND STRING MOVE.L #41,-(SP) JSR ASM_NEWWORDS MOVEA.L UEXCPI,A0 MOVE.W #$5000,(A0) 80 MAX, CURRENT SIZE 0 ADDQ.L #1,UEXCPI MAKE IT POINT TO ST CALL DEBUG FLAG BRA DEBUGXIT2 THEN EXIT NORMALY TTL CLEANUP AFTER PROGRAM ENDED PAGE DBUGEPRG EQU * PROGRAM ENDED MOVEA.L G_DOLLAR,A0 MOVE.L recoverblk(A0),INITRECOVER (scs) move -4(a6),initsr RING PART * JSR ASM_FLUSH_ICACHE BRA DEBUGXIT * PSETUP EQU * CLR.L LASTLINE CLEAR QUEUE BSR QLINE MOVE.W #RTSOP,DEBUGESCAPE KILL ESCAPE TRAP JSR ASM_FLUSH_ICACHE CHG32 3/23/85 TRACECLR BSR CLRFLASH CL (scs) TST.L LASTLINE BEQ DEBUGXIT QUEUE EMPTY MOVEQ #4,D0 CMP.L LASTLINE,D0 BEQ DEBUGXIT ALREADY ENDED MOVE.L D0,LASTLINE BSR QLINE MARK PROG ENDED IN QUEUE BSR CLRBRKS  PEA INSTACK MOVE.L #12,-(SP) NEED 24 BYTES JSR ASM_NEWWORDS MOVE.L INSTACK,D0 ADDQ.L #4,D0 MOVE.L D0,INSTACKB ADD.L #20,D0 MOVE.L D0,INSTACKE * * ALLOW 10 IMPLANTS OF 80 TEXT CHARACTERS * PEA IMFIRST GET IMPEAR LINE AREA MOVE.B #$80,LTFLAGS KILL TRACE CONTROL MOVE.B #$80,TFLAGS RTS TTL INITIALIZE FOR PROGRAM START PAGE DBUGSPRG EQU * SYSTEM WILL START A PROGRAM BSR PSETUP MOVE.L #2,LASTLINE MARK PROG START IN QUEUE BSR QLANT SPACE MOVE.L #450,-(SP) IMSIZE * 10 IMPLANTS / 2 CHG32 rdq JSR ASM_NEWWORDS MOVEA.L IMFIRST,A0 ADDA.L #900,A0 IMSIZE * 10 CHG32 rdq MOVE.L A0,IMLAST MOVEQ #9,D1 CLEAR BREAK POINTS DBUGINIT1 SUBA.L #LINE TST.L 8(A6) DEBUGGER TO CONTOL ? BEQ DEBUGXIT MOVEA.L IMFIRST,A0 SET BREAK #0 MOVEA.L 12(A6),A1 MOVE.L A1,2(A0) ADDRESS CHG32 3/25/85 MOVE.B #$31,(A0) ADDQ.L #6,A0 CHG32 3/23/85 MOVE.W (A1),(A0)+IMSIZE,A0 CLR.B (A0) CLEAR STATUS BYTE MOVE.B #IMSIZE-10,8(A0) SET MAX CHARS. CHG32 rdq DBRA D1,DBUGINIT1 * GET K0..K9 SPACE PEA KDATAP MOVE.W #UDKSIZE,D0 LSR.W #1,D0 DIV 2 TO GET WORD CODE MOVE.W #T15OP,(A1) SET TRAP 15 ADDQ.L #1,A0 MOVE.B #26,(A0)+ STRING LENGTH LEA SMSG,A1 DBUGSP_1 MOVE.B (A1)+,(A0)+ BNE DBUGSP_1 * TRAP ALL EXCEPTIONS EXCEPT ESC 0 AND STOP MOVE.W #JMPOP,DEBUGESCAPE MOVE.L #UES MULU #10,D0 MOVE.L D0,-(SP) UDKSIZE * 10 VARIABLES JSR ASM_NEWWORDS BSR DINITK4 SET DEFAULT K4 VALUE * PEA RECALLV SPACE FOR RECALL MOVE.L #RECALLMAX,D0 LSR.L #1,D0 DIV 2 MOVE.L D0,-(SP) JSR ASM_NXCPE,DEBUGESCAPE+2 JSR ASM_FLUSH_ICACHE CHG32 3/23/85 MOVE.B #2,NUMET RESET ESCAPE TRAP CLR.W ETCODES IGNORE ESC 0 MOVE.W #-20,ETCODES+2 IGNORE STOP BRA DEBUGXIT SYSTEM RECOVER SMSG DC.B 'BC PC^;D "NOW AT EWWORDS * CLR.B RECALLV MARK RECALL EMPTY *** DELETE 5/9/85 JWS MOVE.B #2,DSCODE DEFAULT FORMAT BSR.S PSETUP MOVEA.L G_DOLLAR,A0 SAVE STOP RECOVER MOVE.L recoverblk(A0),INITRECOVER (scs) move -4(ASTART";? ',0 * * CONTROL THE EXIT FROM KEYBOARD ISR * CALLDEBUG EQU * BCLR #1,DSTATUS RELEASE PAUSE/STEP BNE.S DEBUGXIT3 CALL LATER EXIT LEA DBUGCMDS,A1 CTRLEXIT EQU * :CONTROL FROM KEYBOARD ISR BCLR #RUNFLAG,DSTATUS2 6),initsr (scs) MOVE.W #JMPOP,D0 TAKE CONTROL OF MOVE.W D0,TRAP0V SELECTED VECTORS MOVE.L #TRAP0,TRAP0V+2 MOVE.W D0,TRACEV MOVE.L #TRACE,TRACEV+2 MOVE.W D0,TRAP15V MOVE.L #TRAP15,TRAP15V+2 (rdq) MOVE.L A1,PCTEMP SET TARGET ADDRESS MOVE.W #-22,escapecode(A5) DO ESCAPE(-22) (scs) MOVEA.L recoverblk(A5),SP (scs) RTS DEBUGXIT3 EQU * BSET #6,DSTATUS SET5      DISABLE ALL IMPLANTS BSR BRDACA DEACTIVATE ALL MOVE.W #RTSOP,DEBUGESCAPE KILL ESCAPE TRAP JSR ASM_FLUSH_ICACHE BSR TRACECLR CLEAR FLASH DISPLAY AND * TRACE/STEP FUNCTIONS BRA DEBUGXIT TTL  MOVEA.L 12(A6),A0 GET STRING ADDR. MOVEQ #0,D0 MOVE.B (A0)+,D0 GET STRING SIZE CMPI.B #DINBUFMAX,D0 RANGE CHECK SIZE BLE.S DBISR1 MOVEQ #DINBUFMAX,D0 CLIP IT DBISR1 LEA DINSIZE,A1 MOVE.B D0,(A1)+ BRA.S DBISR3 DBISR2 PROCESS DEBUGGER SYSTEM KEYS PAGE DBUGKBD EQU * DEBUGGER KEY RECIEVED * P1=STATUS; P2=DATA CMPI.B #$38,11(A6) PAUSE ? BNE.S DBUGKEY0 BTST #5,15(A6) IF CTRL PAUSE THEN BEQ CALLDEBUG CALL INT MOVE.B (A0)+,(A1)+ COPY STRING TO INPUT BUFFER DBISR3 DBRA D0,DBISR2 LEA DBISRX,A0 SET TO RETURN HERE BRA CTRLEXIT * DBISRX TST.B M68KTYPE FAKE EXCEPTION & DO COMMAND BEQ.S DBISRX1 CLR.W -(SP) DBISRX1 MOVE.L PCTEERPRETER BSET #1,DSTATUS ALREADY WAITING ? BNE DEBUGXIT2 THEN EXIT MOVE.B #'p',TEMPR BSR EXCHANGERUN SWITCH RUNLIGHT WITH TEMPR LEA WAITC,A1 WAIT FOR CONTINUE BRA CTRLEXIT * DBUGKEY0 CMPI.B #$33,11(A6) STMP,-(SP) MOVE.W SRTEMP,-(SP) MOVE.L #DINSIZE,TEMPL BRA DBUGOBEY * DBUGLNUM EQU * SYSTEM WANTS LAST LINE No. MOVEA.L 12(A6),A2 GET ADDRESS OF VAR. BSR GETLNUM MOVE.L (A0),(A2) SET THE NUMBER BRA DEBUGXIT2 * WAITC EP BNE.S DBUGKEY2 BTST #5,15(A6) CTRL STEP BEQ.S DBUGKEY1 * is step go to step mode ORI.B #$42,LTFLAGS SET STEP & FLASH BITS (1,6) BCLR #2,LTFLAGS CLEAR COUNT BIT (2) MOVEQ #'s',D0 BSR.S SHOWSTAT0  EQU * WAIT FOR CONTINUE TYPE KEY TST.B M68KTYPE RESTORE USER RTE INFO. BEQ.S WAITC0 CLR.W -(SP) FAKE VECTOR WORD WAITC0 MOVE.L PCTEMP,-(SP) MOVE.W SRTEMP,-(SP) BCLR #6,DSTATUS CLEAR CALL FLAG MOVE #$200 BRA DEBUGXIT * is ctrl step go to flash mode DBUGKEY1 BSET #6,LTFLAGS SET FLASH FLAG ANDI.B #$F9,LTFLAGS CLEAR STEP & COUNT BITS (1,2) MOVEQ #'f',D0 SET WAITING CHARACTER BSR.S SHOWSTAT0 BRA DEBUGXIT * D0,SR ALLOW KEYBOARD INTERUPTS WAITC1 BTST #1,DSTATUS WAIT FOR FLAG TO CLEAR BNE WAITC1 MOVE #$2100,SR BLOCK KEYBOARD MOVE.L D0,-(SP) BSR RESTORERUN RESTORE RUNLIGHT MOVE.L (SP)+,D0 BCLR #6,DSTATUS BNE DBBUGKEY2 CMPI.B #$3A,11(A6) CONTINUE BNE DEBUGXIT2 ignore unknown key BSR CLRFLASH ANDI.B #$B9,LTFLAGS CLEAR STEP,FLASH & COUNT (BITS 1,2,6) BRA DEBUGXIT * SHOWSTAT0 MOVE.B D0,STAT0CHAR MOVEQ #5,D0 BRA SYSCALL9 (UGCMD2 RTE PAGE DBUGPAUSE EQU * NON ISR WANTS TO PAUSE BSET #1,DSTATUS SET WAIT FLAG MOVE.W -4(A6),SRTEMP SAVE SR MOVE SR,-4(A6) SWITCH SR FOR RETURN TO WAITC MOVE.L 4(A6),PCTEMP SAVE RETURN LEA WAITC,A0 FASYSCALL9 DOES RTS) * DBUGIPLT EQU * CALL FOR COMMAND EXECUTE MOVE.L 12(A6),TEMPL GET STRING ADDR. TST.B M68KTYPE FAKE EXCEPTION ON STACK (rdq) BEQ.S DBUGIPLTA (rdq) CLR.W -(SP) KE RETURN MOVE.L A0,4(A6) MOVE.B #'p',TEMPR BSR EXCHANGERUN BRA DEBUGXIT2 EXIT TO WAIT * DBUGRESET EQU * RESET KEY PRESSED SETUP FOR ACTION LEA DEBUGESCAPE,A0 MOVEM.W (A0),A1-A3 MOVEM.W A1-A3,SAVEHOOK MOVE.W #JMPO FAKE VECTOR WORD (rdq) DBUGIPLTA PEA DEBUGXIT2 (scs) MOVE #$2700,-(SP) SYS MODE PRIORITY 7 (scs) BRA DBUGOBEY * DBISRIPLT EQU * CALL FOR COMMAND EXECUTE FROM ISR P,(A0)+ MOVE.L #DORESET,(A0) LOAD HOOK JSR ASM_FLUSH_ICACHE CHG32 3/23/85 BRA DEBUGXIT2 * DORESET MOVE.W SAVEHOOK,DEBUGESCAPE RESTORE THE ESCAPE HOOK MOVE.L SAVEHOOK+2,DEBUGESCAPE+2 JSR ASM_FLUSH_ICACHE CHG32 3/23/85 A5     .L PCTEMP,-(SP) RESTORE REAL PC MOVE.W SRTEMP,-(SP) RESTORE REAL SR * DBUGCMD2 EQU * ENTRY TO DEBUGGER COMMAND INTERPRETER * ENTRY HERE IS FROM EXCEPTION PROCESSES BSR SAVEREGS BSR SAVECRT BSR.S MONPREP DEBUGC_1 EQU *7,REGSR CLEAR TRACE BIT MOVE.W #$0104,ACCUMT MOVE.L REGPC,ACCUMD CHECK FOR BP BSR FINDACBR BNE.S UPREPC BSET #7,DSTATUS2 EXEC THRU BP BSET #7,REGSR SET TRACE BIT BRA.S UPREPX UPREPC BTST #6,DSTATUS2 TRACE (rdq) BCLR #4,DSTATUS2 CLEAR RESET REQUEST (rdq) BSR DINPUT GET A LINE FROM KEYBOARD MOVEA.L IMFIRST,A1 CLR.B (A1) KILL GT/TT BREAK POINT BCLR #6,DSTATUS2 KILL TRACE MO MODE BEQ.S UPREPD BSET #7,REGSR UPREPD BSR SETBRKS SET TRAP15'S UPREPX MOVEQ #3,D0 BRA SYSCALL9 CLEAR FLASH & RESTORE RUNLIGHT * RTS (SYSCALL9 DOES RTS) * SAVECRT EQU * SAVE USER CRT BTST DDQ.L #4,SP POP RETURN ADDRESS MOVEM.L A0-A6/D0-D7,-(SP) SAVE REGISTERS BSR KBEEP MOVEM.L (SP)+,A0-A6/D0-D7 RESTORE REGISTERS BTST #RUNFLAG,DSTATUS2 DEBUGGER RUNNING ? BEQ.S DORESET1 BSET #4,DSTATUS2 DE ANDI.B #$CF,LTFLAGS KILL P PX AND PN COMMANDS (BITS 4,5) DEBUGC_2 BSR OBEY EXECUTE THE COMMAND STRING BCLR #5,DSTATUS ALL DONE YET BEQ DEBUGC_1 BSR.S USRPREP BCLR #7,DSTATUS ERROR IN PREP ? BNE DEBUGC_1  RESET HAPPENED RTE HOPE FLAG IS SEEN DORESET1 BCLR #1,DSTATUS RELEASE PAUSE/STEP BEQ.S DBUGCMD2 BSET #6,DSTATUS SET CALL FLAG THEN EXIT RTE * TTL COMMAND INTERPRETER PAGE *------------------ BSR UNSAVECRT BRA UNSAVEREGS RESTART USER CODE * MONPREP EQU * COMPLETE CONTEXT SWITCH * ADJUST OPERATING PRIORITY MOVE.W REGSR,D0 {rdq} ANDI.W #$0F00,D0 {rdq} ------------------------------ *------------------------------------------------ * DEBUGGER COMMAND INTERPRETER *------------------------------------------------ *------------------------------------------------ * rdq SEP 81 * DBUGOBEY EQU * EXTER BNE.S MONPREP1 {rdq} MOVE #$0100,D0 AT LEAST LOCKOUT KEYBOARD MONPREP1 ORI.W #$2000,D0 {rdq} MOVE D0,SR {rdq} * BSR CLRBRKS CLEAN UP BREAK POINTS BSR NAL CALL TO OBEY * ENTRY HERE IS FROM EXCEPTION PROCESSES (IMPLANT EXECUTION) BSR SAVEREGS BSR.S MONPREP BCLR #0,DSTATUS2 CHECK 2nd STRING FLAGFLAG BEQ.S DBUGOBEY1 MOVEA.L TEMPL2,A0 PUSH 2nd STRING BSR A0A23 BSR P INPUTCLR CLEAR INSTACK MOVEQ #2,D0 BSR SYSCALL9 SWITCH RUNLIGHT TO 'd' MOVE.B #4,OUTFLAGS SET OUTPUT TO CRT ONLY BSR WRCMD SET STACK FRAME ^ * SHOW LINE NUMBER BSET #1,D7 DON'T DELAY IUSHIN DBUGOBEY1 EQU * MOVEA.L TEMPL,A0 GET STRING PTR BCLR #6,DSTATUS CHECK CALL FLAG BNE.S DEBUGC_2 BSET #5,DSTATUS SET DONE FLAG BRA.S DEBUGC_2 DO IT * DBUGCMDS EQU * ENTRY TO DEBUGGER COMMAND INTERPRETERN FLASH BSR GETLNUM CMPI.B #6,D0 NUMBER BEQ LFLASH FLASH IT AND EXIT RTS * USRPREP EQU * FINAL CHECKS BEFORE USER * GETS CONTROL BCLR #4,DSTATUS2 CHECK RESET REQUEST BNE ERRORX DON'T EXI * ENTRY HERE IS FROM DEBUGGER SYSTEM INTERFACE TST.B M68KTYPE (rdq) BEQ.S DBUGCMDX (rdq) CLR.W -(SP) FAKE VECTOR WORD (rdq) DBUGCMDX MOVET IF SET BTST #0,REGPC+3 CHECK PC BNE.S BADPC BSR GETSP CHECK STACK POINTER BTST #0,3(A0) BEQ.S UPREPB BADPC LEA BADPCM,A0 BSR OUTMSG BRA ERRORX BADPCM DC.B 'PC/SP HAS ODD ADDRESS',0 * UPREPB BCLR #6     #4,DSTATUS CRT SAVED ALREADY ? BNE.S RETURNA BSR.S CRTEXCHG BSET #4,DSTATUS MARK CRT SAVED RETURNA RTS * CRTEXCHG MOVE.B #0,-(SP) EXCHANGE CRT/MEMORY BRA JCALL0 * UNSAVECRT EQU * RESTORE USER CRT BTST #4,DSTATUS  (rdq) UNLK A6 REMOVE TRAP POINTER ANDI.B #$5F,DSTATUS CLR ERROR & DONE FLAGS ANDI.B #$FC,OUTFLAGS CLR CHK & BUFFER FLAGS BSET #2,OUTFLAGS SET CRT FLAG BSR OUTEOL MOVE.L A0,D0 ERROR CODE 0 = EXIT BEQ EEXIT  ALREADY UNSAVED ? BEQ RETURNA BSR CRTEXCHG BCLR #4,DSTATUS CRT NOW UNSAVED RTS * * SAVEREGS EQU * BSET #RUNFLAG,DSTATUS2 (rdq) BTST #0,DSTATUS REGS SAVED ? BNE RETURNA MOVEM.L D0-D7/A0-A6,REGS M BCLR #6,DSTATUS2 CLEAR TRACE BIT OUTMSG EQU * A0 HAS ADDRESS OF TEXT OBEYE MOVE.B (A0)+,D0 BEQ OUTEOL END MESSAGE AND RETURN BSR OUTBYTE OUTPUT THE MESSAGE BRA OBEYE * * EXECUTION COMES HERE FROM DEBUGESCPE VECTOR * EROVEA.L (SP)+,A1 GET RETURN ADDR MOVE.W (SP)+,REGSR MOVE.L (SP)+,REGPC PEA SAVEREGS1 CHG32 MOVE SR,-(SP) RTE * SAVEREGS1 MOVE.L SP,REGA7 REAL STACK POINTER MOVE USP,A0 MOVE.L A0,REGUS BSET #0,DSTATUSROR CONDITION OCCURED IN DEBUGGER BUT SYSTEM TRAPPED IT EXTERRTRAP EQU * MOVEA.L G_DOLLAR,A5 CMPI.W #-28,ESCAPECODE(A5) BEQ.S PTRAP0 RTS IGNORE ANYTHING BUT PARITY ERROR PTRAP0 LEA PARITYMSG+1,A0 BTST #3,DSTATUS RE REGS SAVED MOVE.W DEBUGESCAPE,SAVEESC SWITCH ESCAPE VECTOR MOVE.L DEBUGESCAPE+2,SAVEESC+2 (rdq) MOVE.W #JMPOP,DEBUGESCAPE (rdq) MOVE.L #EXTERRTRAP,DEBUGESCAPE+2 (rdq) JSR ASM_FLUSH_ICACHE COVERY OK ? BNE ESCAPE YES BCLR #0,OUTFLAGS NO PTRAP1 MOVE.B (A0)+,D0 HANGIT BEQ.S HANGIT HANG WHEN LAST CHAR OUT BSR CRTOUT BRA PTRAP1 * * A0 CONTAINS STRING ADDRESS * * CHG32 DON CHG32 3/23/85 JMP (A1) * UNSAVEREGS EQU * MOVEA.L REGUS,A0 MOVE A0,USP MOVEM.L REGS,D0-D7/A0-A7 TST.B M68KTYPE BEQ.S UNSAVEREGS1 CLR.W -(SP) FAKE FORMAT WORD UNSAVEREGS1 MOVE.L REGPC,-(SP) MOVE.W REGSR,-(SP) BCL'T CLEAR HIGH BYTE OF ADDRESS A0A23 MOVEA.L A0,A2 COPY TO A2 FOR USE MOVEQ #0,D0 MOVE.B (A2)+,D0 SIZE MOVEA.L A2,A3 END POINTER ADDA.L D0,A3 RTS * * GIVEN A0 AS A COMMAND POINTER EXECUTE THE COMMAND(S) * OBEY R #0,DSTATUS REGS NOT SAVED * RESTORE ESCAPE VECTOR MOVE.W SAVEESC,DEBUGESCAPE (rdq) MOVE.L SAVEESC+2,DEBUGESCAPE+2 (rdq) JSR ASM_FLUSH_ICACHE CHG32 3/23/85 BCLR #R EQU * BSET #5,DSTATUS2 SET FLAG TO ALLOW EXECUTION BSR A0A23 CONVERT A0 TO A2 A3 LINK A6,#-4 ERROR RECOVERY & SCRATCH SPACE PEA OBEYERR MOVE.L SP,-4(A6) * SWAP CONTROL OF BUS ERROR VECTOR MOVEMUNFLAG,DSTATUS2 (rdq) RTE RETURN TO USER * MBUSERR DC.B 9,'BUS ERROR ',0 MONBUS LEA MBUSERR+1,A0 * ESCAPE MOVEA.L -4(A6),SP CODE IS IN A0 EEXIT RTS * RESTORE_BUSV EQU * (rdq) BCLR #3,DSTA.W BUS_ERRORV,D0-D2 MOVEM.W D0-D2,SAVEBUS MOVE.W #JMPOP,BUS_ERRORV MOVE.L #MONBUS,BUS_ERRORV+2 JSR ASM_FLUSH_ICACHE CHG32 3/23/85 BSET #3,DSTATUS RECOVERY CODE NOW IN PLACE * * A2 IS FRONT POINTER * TUS SET RECOVERY CODE NOT IN PLACE MOVEM.W SAVEBUS,D0-D2 (rdq) MOVEM.W D0-D2,BUS_ERRORV (rdq) RTS (rdq) * OBEYERR EQU * MESSAGE ADDR IN A0 BSR RESTORE_BUSV  A3 IS END POINTER CMDLOOP BSR IFEOI CHECK FOR END OF INPUT BEQ OBEYEND MOVE.B (A2)+,D0 1ST. CHAR CMPI.B #';',D0 END OF COMMAND ? BEQ CMDLOOP NULL COMMAND CMPI.B #' ',D0 BEQ CMDLOOP CMPI.B #'?',D0 HANDL6     ACE LOW BYTE CMDL4 CMP.W D0,D1 BEQ.S CMDXQT CMDL5 ADDQ.L #2,A0 NO MATCH YET BRA CMDCHKEND * CMDXQT BTST #5,DSTATUS2 XQT OR NOT BEQ.S CMDL7 MOVE.W D0,D1 SAVE D0 BTST #7,(A0) BLANK CHECK BEQ.S CMDXQT1 BSR IFTERM BLNKCHK DC.W 'WD' DC.W WCMD-CMDTAB+SIMPLE DC.W 'WS' DC.W WSCMD-CMDTAB+SIMPLE DC.W 'WR' DC.W WRCMD-CMDTAB+SIMPLE DC.W -1 PAGE CMDIN SUBA.L A0,A0 NO MESSAGE BRA ESCAPE FORCE TO INPUT COMMANDS * DEFTD DC.B 'D PC:"PCEQ.S CMDXQT1 CMPI.B #' ',(A2) BNE WHATERR CMDXQT1 BTST #6,(A0) IGNORE REST OF COMMAND BEQ.S CMDXQT2 BSR FINDCMD CMDXQT2 MOVE.W (A0),D0 GET ROUTINE ADDRESS ANDI.W #$3FFF,D0 STRIP CONTROL (rdq) MOVEA.W D0,A0 MOVE.W D=", SR:"SR=",H2 PC^:" ",X;AA;DD ' DEFTDE EQU * SET DEFAULT TD IN K4 DINITK4 LEA DEFTD,A0 MOVE.L A0,K4DATA+2 ADDRESS LEA DEFTDE,A1 SUBA.L A0,A1 MOVE.W A1,K4DATA SET SIZE MOVE.B #$83,K4DATA MARK AS ALPHA RTS * SB_DEFAULT CME ? COMMAND HERE (rdq) BNE.S CMDL00 RDQ 3/15/84 ? SUBJECT TO IF CONTROL BTST #5,DSTATUS2 . BNE CMDIN . BRA CMDL7 RDQ 3/15/84 * CHECK FOR IMPLIED D COMMAND CMDL00 CMPI.B #'A1,D0 RESTORE D0 JSR CMDTAB(A0) DO IT BCLR #7,DSTATUS ERROR RETURN ? BNE.S CMDL8 CMDL7 BSR FINDCMD POSITION TO NEXT COMMAND BRA CMDLOOP CMDL8 BCLR #5,DSTATUS KILL DONE FLAG RTS * OBEYEND BSR RESTORE_BUSV ',D0 IMPLIED D COMMAND BCS.S IMPDCMD IF 1st CHAR IS UPPER OR LOWER ALPHA CMPI.B #'Z',D0 BLS.S CMDL0 CMPI.B #'a',D0 BCS.S IMPDCMD CMPI.B #'z',D0 BHI.S IMPDCMD CMDL0 LSL.W #8,D0 MOVE.B #' ',D0 PAD WITH BLANK BSR I (rdq) UNLK A6 NORMAL EXIT RTS PAGE BLNKCHK EQU $8000 SIMPLE EQU $C000 CMDTAB EQU * DC.W 'A7' DC.W SETA7-CMDTAB+BLNKCHK DC.W 'AA' DC.W DUMPAA-CMDTAB+SIMPLE DC.W 'A#' DC.W SETAREG-CMDTAB+BLNKCHFTERM BEQ.S CMDL1 CMPI.B #' ',(A2) BEQ.S CMDL1 MOVE.B (A2)+,D0 2ND. CHAR CMPI.W #'EL',D0 ELSE COMMAND BNE.S CMDL1 BCHG #5,DSTATUS2 TOGGLE THE XQT ENABLE BRA CMDL7 CMDL1 CMPI.W #'EN',D0 END COMMAND BNE.S K DC.W 'B@' DC.W BRCMDS-CMDTAB+BLNKCHK DC.W 'CA' DC.W CALLCMD-CMDTAB+BLNKCHK DC.W 'DD' DC.W DUMPDD-CMDTAB+SIMPLE DC.W 'D#' DC.W SETDREG-CMDTAB+BLNKCHK DC.W 'D ' DC.W DCMD-CMDTAB DC.W 'DE' DC.W DECMD-CMDTAB+SI CMDL2 BSET #5,DSTATUS2 SET XQT ENABLE BRA CMDL7 CMDL2 LEA CMDTAB,A0 ADDRESS OF COMMAND TABLE CMDCHKEND TST.W (A0) BPL.S CMDL3 * COMMAND NOT FOUND WHATERR LEA WHATM,A0 BRA ESCAPE WHATM DC.B 'MPLE DC.W 'D@' DC.W DAGCMD-CMDTAB+SIMPLE DC.W 'EC' DC.W ESCCMD-CMDTAB+BLNKCHK DC.W 'ET' DC.W ETCMD-CMDTAB DC.W 'F@' DC.W FCMD-CMDTAB+SIMPLE DC.W 'G@' DC.W GOCMD-CMDTAB DC.W 'IF' DC.W IFCMD-CMDTAB+BLNKCHK DC.WHAT?',0 SYNTAXE LEA SYNTAXM,A0 BRA ESCAPE SYNTAXM DC.B 'SYNTAX ERROR',0 * IMPLIED D COMMAND IMPDCMD MOVE.B D0,-(A2) PUT BACK THE CHARACTER BSR PUSHIN LEA DOPC,A2 LEA 2(A2),A3 BRA CMDLOOP RESTART THE SCW 'K#' DC.W UDKCMDS-CMDTAB+BLNKCHK DC.W 'O@' DC.W OPENCMD-CMDTAB+BLNKCHK DC.W 'PC' DC.W SETPC-CMDTAB+BLNKCHK DC.W 'P@' DC.W PROCCMD-CMDTAB+SIMPLE DC.W 'Q@' DC.W QCMD-CMDTAB+SIMPLE DC.W 'sb' DC.W SYSBOOT-CMDTABAN DOPC DC.B 'D ' * CMDL3 MOVE.W (A0)+,D1 GET CMD FROM TABLE CMPI.B #'@',D1 BEQ.S CMDL3A CMPI.B #'#',D1 BNE.S CMDL4 SECOND CHAR IS 0..7 CMPI.B #'0',D0 BCS.S CMDL5 CMPI.B #'9',D0 BHI.S CMDL5 CMDL3A MOVE.B D0,D1 REPL+BLNKCHK DC.W 'SF' DC.W WDUMP-CMDTAB+SIMPLE DC.W 'SR' DC.W SETSR-CMDTAB+BLNKCHK DC.W 'SP' DC.W SETSP-CMDTAB+BLNKCHK DC.W 'TD' DC.W TDCMD-CMDTAB+BLNKCHK DC.W 'T@' DC.W TCMD-CMDTAB DC.W 'US' DC.W SETUS-CMDTAB+B7     PI.B #'*',(A2) RTS SYSBOOT EQU * * * 10/21/88 DEW & QUIST * ADDED SUPPORT FOR NAMED REBOOT EXTENSTIONS * *=========================================================== * KLUDGE ADDED 2/11/91. If you do an 'sb' command froER FROM USER, PUT IT IN ROM D AREA BRA.S SB_ST_ADDR FSUNITSTR DC.B 'UNIT NUMBER INVALID FOR BOOT.',0 SB_UNITERR EQU * LEA FSUNITSTR,A0 BRA ESCAPE SB_FSUNIT EQU * MOVE.B #' ',(A2) BSR GETCOUNT MOVE.L ACCUMD,TEMPL MOVEQ #10,D0 m the * debugger and an FP exception is pending, the reboot fails * and the system hangs. Could be a Boot ROM bug. JWH 2/11/91. BTST #3,SYSFLAG2 BNE NOTTA_40 trap #11 FSAVE 256 fmove.l #0,FPSTATUS move (sp)+,SR NOTTA_BSR SYSCALL TST.L TEMPL3 BNE SB_UNITERR MOVE.L TEMPL2,$FFFFFEDC SB_ST_ADDR EQU * CHECK FOR A STATION ADDRESS BSR FINDNP BSR IFTERM IF AT END OF COMMAND BEQ SB_GOROM DEFAULT THE STATION ADDRESS. BSR S40 equ * *========================================================== BSR FINDNP BSR IFTERM IF AT END OF COMMAND BNE.S SB_NEW SB_OLD CLR $FFFFFDC2 CLEAR SYSTEM NAME SB_GOROM EQU * CLR.B -(SP) ROM CACHE MODE JSR B_DEFAULT IF CHARACTER IS THE DEFAULT CHARACTER BEQ SB_GOROM BSR GVALUE GET THE USERS STATION ADDRESS CMPI.B #$83,ACCUMT BNE.S SB_SERR CMPI.B #12,ACCUMS BNE.S SB_SERR MUST BE 12 CHARACTERS. MOVEQ #11,D1 MOVEA.L ASM_CACHE_MODE TURN OFF ALL CACHES JMP $1C0 HAVE BOOT ROM BOOT A SYSTEM SB_NEW EQU * SB_NAME EQU * GET THE SYSTEM NAME. BSR SB_DEFAULT CHECK FOR DEFAULT CHARACTER BEQ.S SB_MSUS BSR GVALUE GET THE USERS SYSTE ACCUMD,A2 MOVE.W #16,BASE LEA TEMPL,A0 MOVEQ #0,D2 SB_ST1 EQU * CONVERT THE 12 DIGIT ADDR TO 6 BYTE # MOVE.B (A2)+,D0 BSR GETHEX BCLR #7,DSTATUS CHECK FOR AN ERROR BNE.S SB_SERR BTST #0,D1 BEQ.S SB_STM NAME AND VERIFY CMPI.B #$83,ACCUMT BNE.S SB_NERR MOVEQ #0,D0 MOVE.B ACCUMS,D0 CMPI.B #$10,D0 BGT.S SB_NERR CMPI.B #$0,D0 BEQ.S SB_MSUS MOVE.L D0,D1 NAME VERIFIED, MOVE PADDED W/SPACES TO ROM SUBI.L #1,D0 LEA $FFFFFDC2,A2 MOVE.B D0,D2 BIT IS SET, PUT IN LOW NIBBLE OF D2 BRA.S SB_ST3 SB_ST2 EQU * SHIFT D2, PUT IN LOW NIBBLE, STORE ASL #4,D2 OR.B D0,D2 MOVE.B D2,(A0)+ MOVEQ #0,D2 SB_ST3 EQU * DBRA D1,SB_ST1 LEA T0 MOVEA.L ACCUMD,A1 SB_T1 MOVE.B (A1)+,(A0)+ DBRA D0,SB_T1 MOVEQ #10,D0 SUB.B D1,D0 BRA.S SB_T3 SB_T2 MOVE.B #' ',(A0)+ SB_T3 DBRA D0,SB_T2 BRA.S SB_MSUS NERRSTR DC.B 'BAD SYSTEM NAME',0 SB_NERR EQU * THE NAME ENTERED ISEMPL,A0 BTST #0,(A0) reject broadcast and multicast BNE.S SB_SERR MOVEA.L $FFFFFED4,A1 MOVE.L (A0)+,(A1)+ MOVE.W (A0),(A1) BRA SB_GOROM SERRSTR DC.B 'STATION ADDRESS ERROR.',0 SB_SERR EQU * LEA SERRSTR,A0 BRA ESCAP NOT A GOOD ONE. LEA NERRSTR,A0 BRA ESCAPE SB_MSUS EQU * BSR FINDNP BSR IFTERM IF AT END OF COMMAND BEQ SB_GOROM DEFAULT THE MSUS AND THE STATION ADDRESS. BSR SB_DEFAULT IF CHARACTER IS THE DEFAULT CHARACTER E * IFCMD BSR GETGVALUE IF COMMAND TST.B ACCUMT BEQ SYNTAXE BSR LSIZE TST.L ACCUMD BEQ.S IFCMDC BSET #5,DSTATUS2 EXECUTE NEXT COMMAND RTS IFCMDC BCLR #5,DSTATUS2 DON'T EXECUTE NEXT COMMAND RTS * ESCCMD EQU BEQ.S SB_ST_ADDR DEFAULT MSUS, GET THE STATION ADDR. CMPI.B #'#',(A2) FS UNIT NUMBER REQUEST? BEQ.S SB_FSUNIT LEA -1(A2),A2 GETCOUNT CALLS FINDNP BSR GETCOUNT GET THE USERS MSUS MOVE.L ACCUMD,$FFFFFEDC GOOD NUMB * ESCAPE COMMAND BSR GETCOUNT BSR WSIZE BTST #0,REGA7+3 BNE BADPC BTST #0,REGPC+3 BNE BADPC LEA FAKEESC,A0 GET RETURN ADDRESS MOVEA.L G_DOLLAR,A5 MOVE.W ACCUMD,ESCAPECODE(A5) SET ESCAPE CODE FAKEXIT MOVE7      FRONT POINTER POPEND RTS * * PUT NEXT ENTRY PUSHIN MOVEA.L INSTACK,A0 STACK HAS MAX 4 ENTRIES CMPA.L INSTACKB,A0 BEQ.S PUSHERR OVERFLOW MOVE.L A3,-(A0) SAVE END MOVE.L A3,D7 JWS 6/12/85 SUB.L A2,D7 T.B ACCUMT BEQ.S DUMPREG BSR SIZE4 MAKE 4 BYTES BSR AFETCH GET DATA IF ADDRESS MOVEA.L (SP)+,A0 GET REG ADDRESS MOVE.L ACCUMD,(A0) RTS PAGE BLANK DC.B ' ' DUMPREG MOVE.W #$0104,ACCUMT ADDRESS TYPE 4 BY JWS 6/12/85 MOVE.W D7,-(A0) JWS 6/12/85 SAVE SIZE MOVE.L A0,INSTACK RTS PUSHERR LEA PUSHEM,A0 BRA ESCAPE PUSHEM DC.B 'INPUT OVERFLOW',0 INPUTCLR MOVEA.L INSTACKE,A0 KILL FURTHER INPUT MOVE.L A0,INSTACK MOVEA.L A2,A3 RTS TES MOVE.L (SP)+,ACCUMD ADDRESS OF REG DUMPR2 BSR PUSHIN SAVE CURRENT INPUT LEA BLANK,A2 LEA 1(A2),A3 BLANK FORMAT BSR FORMAT DUMP THE REGISTER BRA OUTEOL NEW LINE (IT DOES RTS) * SETSR BSR GETGVALUE TST.B A.L REGPC,PCTEMP SAVE PC & SR MOVE.L A0,REGPC CONTROL THE RETURN MOVE.W REGSR,SRTEMP MOVE.W #$2700,REGSR BSR INPUTCLR MOVE.W #'G ',D0 BRA GOCMD * FAKEESC TST.B M68KTYPE GENERATE EXCEPTION INFO BEQ.S FESC1 MOVE.W #$A TTL COMMAND EXECUTE CODE PAGE * * COMMAND EXECUTE CODE * SETBRKS EQU * SET TRAP15'S MOVEM.L A0-A1,-(SP) MOVEA.L IMFIRST,A0 SETBRKS1 CMPI.B #$11,(A0) ADDRESS BREAK BNE.S SETBRKS2 MOVEA.L 2(A0),A1 CHG32 3/23/85 MOVE.W (8,-(SP) FAKE VECTOR WORD FESC1 MOVE.L PCTEMP,-(SP) MOVE.W SRTEMP,-(sp) ANDI.B #$07,SRTEMP MASK PRIORITY BSET #5,SRTEMP SET SUPER BIT MOVE SRTEMP,SR JMP TRAP10V JUMP TO TRAP #10 VECTOR CALLCMD EQU * CALLA1),6(A0) GET USER CODE/ CHG32 3/23 MOVE.W #T15OP,(A1) BRA.S SETBRKS3 SETBRKS2 CMPI.B #$12,(A0) LINE BREAK BNE.S SETBRKS4 BSET #0,LTFLAGS SETBRKS3 BSET #5,(A0) MARK ACTIVE SETBRKS4 ADDA.L #IMSIZE,A0 NEXT BREAK CMPA.L IMLAST, COMMAND BSR GETADDR GET ROUTINE ADDRESS BTST #0,3(A0) BNE ADDRERROR MOVE.L (A0),TEMPL4 BTST #0,REGPC+3 CHECK RETURN PC BNE BADPC BSR GETSP CHECK STACK POINTER BTST #0,3(A0) BNE BADPC LEA DA0 BNE SETBRKS1 JSR ASM_FLUSH_ICACHE MOVEM.L (SP)+,A0-A1 RTS * CLRBRKS EQU * ROUTINE TO DISABLE IMPLANTS MOVEM.L A0/A1,-(SP) MOVEA.L IMFIRST,A0 CLEAR ACTIVE INST. BREAKS CLRIB3 CMPI.B #$31,(A0) T15 BREAK ? BNE.S CLRIB4OCALL,A0 SET RETURN ADDRESS BRA FAKEXIT * DOCALL MOVE SRTEMP,SR MOVE.L PCTEMP,-(SP) MOVE.L TEMPL4,-(SP) RTS * CHECK FOR END OF BUFFER/COMMAND IFTERM BSR.S IFEOI CHECK FOR END OF INPUT BEQ.S IFTRET CMPI.B #';',(A2) END MOVEA.L 2(A0),A1 CHG32 3/23/85 MOVE.W 6(A0),(A1) RESTORE USER CODE/CHG32 CLRIB4 BCLR #5,(A0) MARK INACTIVE ADDA.L #IMSIZE,A0 CMPA.L IMLAST,A0 BNE CLRIB3 CLRBXIT MOVEM.L (SP)+,A0/A1 BCLR #0,LTFLAGS JSR ASM_FLUS OF COMMAND IFTRET RTS * CHECK FOR END OF INPUT IFEOI CMPA.L A2,A3 BNE.S IFEOI0 BSR.S POPIN BNE IFEOI IFEOI0 RTS * * ROUTINES TO HANDLE INPUT STACK * GET NEXT ENTRY POPIN MOVEA.L INSTACK,A2 MOVEA.L A2,A3 COPY H_ICACHE RTS PAGE * SET/DISPLAY REGISTERS * SETA7 LEA REGA7,A0 BRA.S SETREG * SETAREG CMPI.B #'7',D0 BHI WHATERR LEA AREGS,A0 REGOFSET ANDI.L #$F,D0 LSL.L #2,D0 * 4 ADDA.L D0,A0 REG ADDR BRA.S SETREG * SETDREG CMPI.BIN CASE IS END CMPA.L INSTACKE,A2 JWS 6/12/85 BEQ.S POPEND EMPTY MOVEQ #0,D7 MOVE.W (A2)+,D7 SIZE JWS 6/11/85 MOVEA.L (A2)+,A3 END POINTER MOVE.L A2,INSTACK SAVE IN PTR. MOVEA.L A3,A2 SUBA.L D7,A2  #'7',D0 BHI WHATERR LEA DREGS,A0 BRA REGOFSET * SETPC LEA REGPC,A0 BRA.S SETREG * SETUS LEA REGUS,A0 BRA.S SETREG * SETSP BSR GETSP * SETREG MOVE.L A0,-(SP) SAVE POINTER BSR GETGVALUE VALUE ? TS8     CCUMT BNE.S SETSR1 MOVE.W #$0402,ACCUMT HEX 2 BYTES MOVE.W REGSR,ACCUMD BRA DUMPR2 SETSR1 BSR UPKACCM CMPI.B #1,D0 ADDRESS ? BNE.S SETSR2 BSR AFETCH MOVE.B #2,ACCUMS SET SIZE2 SETSR2 BSR SIZE2 MOVE.W ACCUMD,REGRESS=",,/,"DATA OUT=",,16>," IN=",,/ ' EXFMT10E EQU * * * DUMP EXCEPTION INFO COMMAND * DECMD BSR OUTEOL LEA EXCPM,A0 PRINT "-EXECPTION-" BSR OUTMSTR MOVEA.L G_DOLLAR,A5 CMPI.W #-12,escapecode(A5) (scs) BEQ SR RTS * DRFMT DC.B ' D0:/,"D0=", D3:"D3=",' DC.B ' D6:"D6=", D1:/,"D1=",' DC.B ' D4:"D4=", D7:"D7=",' DC.B ' D2:/,"D2=", D5:"D5=",' DRFMTE EQU * * ARFMT DC.B ' A0:/,"A0=", A3:"A3=",' DC.B ' A6:"A6=", A1:/,"A1=",' DC.B ' BUSEXCP CMPI.W #-11,escapecode(A5) (scs) BEQ ADDEXCP CMPI.W #-28,ESCAPECODE(A5) (rdq) BEQ PARITYEXCP * MISC. ESCAPE CODES DECMD_A BSR PUSHIN LEA EXFMT1,A2 DUMP ESCAPE COD A4:"A4=", SP:"SP=",' DC.B ' A2:/,"A2=", A5:"A5=",' ARFMTE EQU * * * DUMP D REGS COMMAND * DUMPDD BSR PUSHIN LEA DRFMT,A2 LEA DRFMTE,A3 BRA.S DCMD * * DUMP A REGS COMMAND * DUMPAA BSR PUSHIN LEA ARFMT,A2 LEE LEA EXFMT1E,A3 BSR DCMD DUMP WILL POP INPUT * DECODE & DISPLAY FRAME DATA DECMD_B TST.B M68KTYPE BEQ.S EXCPEND MOVE.B EXCP_VOFFSET,D0 have 680xx ANDI.B #$F0,D0 TST.B D0 BEQ.S EXCPEND A ARFMTE,A3 DROP TO DCMD PAGE * * DUMP / DISPLAY COMMAND * DCMD EQU * DCMD0 BSR INGVALUE TST.B ACCUMT BEQ OUTEOL CR LF THEN EXIT BSR IFTERM BEQ.S DCMD1 MOVE.B (A2)+,D0 CMPI.B #' ',D0 BEQ.S DCMD2 CMPI.B #':' format 0000 MOVE.W #$0104,ACCUMT MOVE.L #ERR_INFO,ACCUMD BSR PUSHIN CMPI.B #$80,D0 format 1000 BNE.S DECMD_D LEA EXFMT5,A2 is 68010 long format LEA EXFMT5E,A3 DECMD_C BSR FORMAT PRINT IT BSR FINDNP,D0 BNE SYNTAXE DCMD1 CLR.W LINECOUNT COUNT OUTPUT LINES BSET #0,OUTFLAGS BSR FORMAT PRINT IT BCLR #0,OUTFLAGS DON'T COUNT LINES BRA DCMD0 * DCMD2 SUBQ.L #1,A2 BACKUP BRA DCMD1 BLANK FORMAT * PAGE  REPOSITION THE INPUT BRA.S EXCPEND * 68020 FORMAT STUFF DECMD_D CMPI.B #$20,D0 BNE.S DECMD_E LEA EXFMT7,A2 format 0010 LEA EXFMT7E,A3 BRA DECMD_C DECMD_E CMPI.B #$90,D0 BNE.S DECMD_F LEA EXFMT8,A2 for* DUMP EXCEPTION DATA EXCPM DC.B 11,'-EXCEPTION-' EXFMT1 DC.B ' EC:"ESCAPE CODE",I2 ' EXFMT1E EQU * EXFMT2 DC.B '"INFO=",H2,"ADDRESS=",,"INSTR=",H2,/ ' EXFMT2E EQU * EXFMT3 DC.B '"SR=",H2,"PC=",,2>,"LINE",I ' mat 1001 LEA EXFMT8E,A3 BRA DECMD_C DECMD_F CMPI.B #$A0,D0 format 1010 BNE.S DECMD_G LEA EXFMT9,A2 LEA EXFMT9E,A3 BRA DECMD_C DECMD_G CMPI.B #$B0,D0 format 1011 BNE.S EXCPEND LEA EXFMT10,A2 LEA E 68000 EXFMT3E EQU * EXFMT4 DC.B '"SR=",H2,"PC=",,"FMT=",H2,"LINE",I ' 680xx EXFMT4E EQU * EXFMT5 DC.B '"INFO=",H2,"ADDRESS=",,2>,/,' DC.B '"DATA OUT=",I2,2>,"IN=",I2,2>,"INSTR=",H2,/ ' EXFMT5E EQU * * EXFMT6 IS NO LONGEXFMT10E,A3 BRA DECMD_C EXCPEND BSR PUSHIN MOVE.W #$0104,ACCUMT MOVE.L #EXCP_STATUS,ACCUMD TST.B M68KTYPE (rdq) BEQ.S EXCPEND1 (rdq) LEA EXFMT4,A2 680xx (rdq) LEA EXR USED * 68020 FORMATS EXFMT7 DC.B '"ERROR PC=",,/ ' EXFMT7E EQU * EXFMT8 DC.B '"ERROR PC=",,4>,"ERROR EA=",,/ ' EXFMT8E EQU * EXFMT9 DC.B '"INFO=",H4,8>,"ADDRESS=",,/,"DATA=",,/ ' EXFMT9E EQU * EXFMT10 DC.B '"INFO=",H4,8>,"ADDFMT4E,A3 (rdq) BRA.S EXCPEND2 (rdq) EXCPEND1 LEA EXFMT3,A2 68000 LEA EXFMT3E,A3 EXCPEND2 BSR FORMAT BRA OUTEOL BUSEXCP LEA MBUSERR,A0 (rdq) BEDUMPR BSR OUTMS8     NPUTCLR DISCARD INPUT BUFFER * AND GO GOCMDB BSR T0FLASH HAVE F LOOK FOR T BSR IFTERM BEQ GOUSER CMPI.B #'T',(A2) BNE GOCMDA * GOCMDC BSR BRSET SET BREAK POINT BRA GOUSER * GOCMDD BSR #1,ACCUMT ADDRESS MOVE.B #4,ACCUMS SIZE QCMD0 MOVE.B #21,TCOUNT LOOP COUNT QCMD1 MOVEA.L TEMPL,A0 CMPI.L #2,(A0) PROG START BEQ QPROGS CMPI.L #4,(A0) PROG END BEQ QPROGE BSR PUSHIN SAVE CURRENT INPUT LEA QFM IFTERM HAVE T LOOK FOR F BEQ GOCMDC CMPI.B #'F',(A2) BNE GOCMDC BSR T0FLASH BRA GOCMDC PAGE * ESCAPE TRAP COMMAND * ETCMD BSR IFTERM BEQ.S ETONLY MOVE.B (A2),D0 CMPI.B #' ',D0 BEQ.S ETONLY CMPI.B #'C',D0 T2,A2 LEA QFMT2E,A3 MOVEA.L ACCUMD,A1 CMPI.W #$4E40,(A1) LINE # ? BNE.S QCMD2 LEA QFMT1,A2 LEA QFMT1E,A3 QCMD2 BSR FORMAT BSR FINDNP QCMD3 BSR.S QBWD BACK UP IN THE Q BEQ.S QCMDRET SUBQ.B #1,TCOUNT BNE QTR TST.B M68KTYPE (rdq) BNE DECMD_B do 680xx (rdq) MOVE.W #$0104,ACCUMT BUG FIX 3.0 MOVE.L #ERR_INFO,ACCUMD BUG FIX 3.0 BSR PUSHIN BUG FIX 3.0 LEA EXFMT2,A2 is 68000 LEA E BEQ ETIMP CMPI.B #'N',D0 BNE SYNTAXE * ERROR TRAP NOT MOVE.W #RTSOP,SAVEESC DEFAULT BSR.S ETLIST NO LIST TST.B NUMET ANY LIST ? BEQ.S ETCMDX MOVE.W #JMPOP,SAVEESC MOVE.L #UEXCPE,SAVEESC+2 ETCMDX RTS *XFMT2E,A3 BEDUMPR3 BSR FORMAT BSR FINDNP REPOSITION INPUT BRA EXCPEND ADDMSG DC.B 13,'ADDRESS ERROR' ADDEXCP LEA ADDMSG,A0 BRA BEDUMPR PARITYMSG DC.B 16,'RAM PARITY ERROR',0 PARITYEXCP LEA PARITYMSG,A0 BSR OUTMSTR TST.L ETLIST CLR.B NUMET COUNT LEA ETCODES,A0 GETECODES EQU * MOVE.L A0,-(SP) BSR GETCOUNT TST D0 DONE ? BEQ.S GETEXITA CMPI.B #4,NUMET BEQ.S TOOMANY BSR WSIZE TRIM TO WORD SIZE MOVEA.L (SP)+,A0 MOVE.W ACCUMD,(A0)+ FAULT_ADDR BEQ EXCPEND BRA DECMD_B PAGE * FORMAT DEFAULT SETTING COMMAND * FCMD LEA SPECT,A0 MOVEQ #16,D1 CHECK FOR OCTAL CMP.B 16(A0),D0 BEQ.S FCMD2 MOVEQ #6,D1 FCMD1 CMP.B 0(A0,D1),D0 SCAN FOR MATCH ADDI.B #1,NUMET BRA GETECODES GETEXITA MOVEA.L (SP)+,A0 RTS TOOMM DC.B 'TOO MANY CODES',0 TOOMANY LEA TOOMM,A0 BRA ESCAPE * * ERROR TRAP ONLY ETONLY MOVE.W #JMPOP,SAVEESC DEFAULT MOVE.L #UEXCPA,SAVEESC+2 NO LIST B DBEQ D1,FCMD1 BNE WHATERR CMPI.B #2,D1 BLT WHATERR CMPI.B #3,D1 BEQ WHATERR DON'T ALLOW ALPHA FCMD2 MOVE.B D1,DSCODE SET THE DEFAULT RTS PAGE * T0NORM ANDI.B #$81,LTFLAGS OFF BITS 1..6 RTS T0FLASH BSET #6,LTFLAGSSR ETLIST TST.B NUMET ANY LIST ? BEQ.S ETEXIT MOVE.L #UEXCPO,SAVEESC+2 ETEXIT RTS * ETIMP BSR GETGVALUE BSR UPKACCM CMPI.B #3,D0 BNE SYNTAXE MOVE.W #JMPOP,SAVEESC MOVE.L #UEXCPIMP,SAVEESC+2 MOVE.L UEXCPI,-(SP) ADDRES ANDI.B #$C1,LTFLAGS OFF BITS 1..5 RTS * * GO COMMAND * GOCMD BCLR #6,DSTATUS2 CLEAR TRACE BIT BSET #2,DSTATUS SET GO BIT BSR T0NORM NORMAL TRAP 0 CMPI.B #' ',D0 BEQ.S GOCMDA CMPI.B #'F',D0 BEQ.S GOCMDB CMPI.BS OF VECTOR BRA BRSETC PAGE * DUMP LINE/PC QUEUE * QCMD CMPI.B #' ',D0 BEQ.S DUMPQ CMPI.B #'S',D0 BEQ.S STARTQ CMPI.B #'E',D0 BNE WHATERR ENDQ MOVEQ #4,D0 BCLR #7,LTFLAGS BCLR #7,TFLAGS BEQ ETEXIT ALREADY  #'T',D0 BEQ.S GOCMDD BRA WHATERR * GOCMDA BSR GETCOUNT COUNT OR NOTHING BEQ.S GOUSER CONDITION SET BY GETCOUNT MOVE.L ACCUMD,TCOUNT BSET #2,LTFLAGS SET COUNT FLAG GOUSER BSET #5,DSTATUS SET DONE FLAG BRA IENDED BRA.S MARKQ STARTQ MOVEQ #2,D0 BSET #7,LTFLAGS BSET #7,TFLAGS BNE ETEXIT ALREADY STARTED MARKQ MOVE.L D0,LASTLINE BRA QLINE * DUMPQ MOVEA.L QLAST,A0 CLR.L (A0) MOVE.L A0,TEMPL BSR QBWD BEQ QEMPTY MOVE.B 9     CMD1 MOVEQ #0,D1 QCMD4 LEA QPMSG,A0 BSR.S OUTMSTR BSR DINPUT BTST #5,DSTATUS DONE FLAG ? BNE.S QCMDRET BSR A0A23 BSR IFEOI BEQ QCMD0 BSR SNEWCMD START NEW COMMAND QCMDRET RTS QPMSG DC.B 5,'MORE ' *  TYPEERROR ALPHA TST.B D0 BEQ.S TYPEERROR NULL WSIZE2 MOVEQ #0,D2 SIGN CMPI.B #2,D1 SIZE CHECK BEQ.S WSIZED BCS.S WSIZEB CMPI.B #2,D0 SIGNED ? BNE.S WSIZEA BTST #7,-2(A0,D1) SNE D2 SET SIGN BYTE WSIZEA  BACK UP IN THE QUEUE QBWD MOVEA.L TEMPL,A0 CMPA.L QSTART,A0 BNE.S QBWD1 MOVEA.L QEND,A0 QBWD1 TST.L -(A0) BEQ.S QBWDR MOVE.L A0,TEMPL MOVE.L (A0),ACCUMD QBWDR RTS * QFMT1 DC.B '4>,*,2<,U2,/ ' QFMT1E EQU * QFMT2 DC.B  CMP.B (A0),D2 SIGN CHECK BNE.S SIZEERROR ADDQ.L #1,A0 SUBQ.L #1,D1 CMPI.B #2,D1 BNE WSIZEA WSIZED MOVE.B (A0)+,ACCUMD MOVE.B (A0),ACCUMD+1 BRA.S WSIZEC WSIZEB MOVE.B (A0),ACCUMD+1 BYTE CLR.B ACCUMD ASSUME BYTE IS UNSIGNED WS'*,/ ' QFMT2E EQU * * QEMPM DC.B 6,'EMPTY ' QEMPTY LEA QEMPM,A0 * OUTMSTR MOVEQ #0,D1 MOVE.B (A0)+,D1 BSR OUTALPHA BRA OUTEOL (IT DOES RTS) QSPM DC.B 6,'START ' QEPM DC.B 4,'END ' QPROGS LEA QSPM,A0 QOUTM BSIZEC MOVE.B #2,ACCUMS BRA.S SIZEXIT * SIZEERROR LEA SIZEM,A0 BRA ESCAPE TYPEERROR LEA TYPEM,A0 BRA ESCAPE SIZEM DC.B 'SIZE ERROR',0 TYPEM DC.B 'TYPE ERROR',0 * SIZE4 BSR UPKACCM TST.B D0 NULL BEQ TYPEERROR CR OUTMSTR BRA QCMD3 QPROGE LEA QEPM,A0 BRA QOUTM TTL EXECUTION UTILITIES PAGE * * GET LINE # OR ADDRESS (LINE # IS 0..65535) GETLNA BSR GETGVALUE BSR UPKACCM TST D0 ANY INPUT ? BEQ.S GETLRET CMPI.B MPI.B #3,D0 ALPHA BNE.S LSIZE4 CMPI.B #4,D1 BHI SIZEERROR MOVEQ #0,D2 BRA.S LSIZEB ANY THING SIZE 4 * * MAKE ACCUMULATOR NUMERIC LONG * LSIZE BSR UPKACCM CMPI.B #3,D0 ALPHA BEQ TYPEERROR TST D0 NULL BEQ TYP#1,D0 ADDRESS ? BEQ.S GETLRET BSR LSIZE MAKE ACCUM. NUMERIC INTEGER TST.W ACCUMD BNE SIZEERROR MOVE.B #2,ACCUMS REDUCE TO TWO BYTES MOVE.W ACCUMD+2,ACCUMD LEFT JUSTIFY IT MOVE.B #6,ACCUMT TYPE IS UNSIGNED INT BSR EERROR LSIZE4 MOVEQ #0,D2 BTST #7,(A0) BEQ.S LSIZEB CMPI.B #2,D0 SIGNED ? BNE.S LSIZEB MOVEQ #-1,D2 BRA.S LSIZEB LSIZEA LSL.L #8,D2 MOVE.B (A0)+,D2 LSIZEB DBRA D1,LSIZEA MOVE.B #4,ACCUMS MOVE.L D2,ACCUMD SIZEXIT MOVE.B UPKACCM GETLRET RTS * GETADDR BSR GETGVALUE GET ADDRESS BSR UPKACCM TST D0 BEQ SYNTAXE CMPI.B #1,D0 ADDRESS ? BNE TYPEERROR RTS * * MAKE ACCUMULATOR ANY THING SIZE 1 SIZE1 BSR.S SIZE2 REDUCE TO SIZE 2 BSR D0,ACCUMT RTS TTL COMMAND EXECUTE CODE PAGE * BREAK POINT(IMPLANT) COMMANDS * BRCMDS BCLR #2,DSTATUS CLEAR GO/BR FLAG CMPI.B #' ',D0 BEQ.S BRDUMP CMPI.B #'C',D0 BEQ BRKILL CMPI.B #'S',D0 BEQ BRSET CMPI.B #'A',D0  UPKACCM MOVEQ #0,D2 SIGN CMPI.B #2,D0 SIGNED ? BNE.S SIZE1A BTST #7,1(A0) CHECK SIGN SNE D2 SIZE1A CMP.B (A0)+,D2 BNE.S SIZEERROR MOVE.B #1,ACCUMS MOVE.B (A0),ACCUMD RTS * * MAKE ACCUMULATOR ANY THING SIZE 2 SIZE2 BBEQ BRACT CMPI.B #'D',D0 BEQ BRDAC BRA WHATERR BRHEADER DC.B 12,'BREAK POINTS' BRULINE DC.B 12,'------------' BRDUMP LEA BRHEADER,A0 BSR OUTMSTR PRINT THE HEADER LEA BRULINE,A0 BSR OUTMSTR BSR GETLNA DUMP BREASR UPKACCM TST.B D0 NULL BEQ.S TYPEERROR CMPI.B #3,D0 ALPHA BNE.S WSIZE2 CMPI.B #2,D1 BHI.S SIZEERROR BRA.S WSIZE2 ANY THING SIZE 2 * * MAKE ACCUMULATOR NUMERIC WORD (2 BYTES) * WSIZE BSR UPKACCM CMPI.B #3,D0 BEQ.S K POINT(S) TST D0 BNE.S BRDUMPC MOVEA.L IMFIRST,A0 DUMP ALL BRDUMPA TST.B (A0) BEQ.S BRDUMPB BSR.S OUTBR BRDUMPB ADDA.L #IMSIZE,A0 CMPA.L IMLAST,A0 BNE BRDUMPA RTS BRDUMPC BSR.S FINDACBR BEQ.S OUTBR A0 HAS BREAK ADDRES9     E.B (A0)+,D1 BSR OUTALPHA BRA.S OUTBRD OUTBRC ADDQ.L #1,A0 COUNT BREAK MOVE.W #4,D1 BSR OUTINT OUTBRD MOVEA.L (SP)+,A0 RECALL THE POINTER BRA OUTEOL * BRKILL BSR GETLNA TST D0 BNE.S BRKILLB MOVEA.L IMFIRST,A0 T ? BEQ.S BRSETB1 MOVE.B #1,ACCUMD+3 count 1 BRA.S BRSETB1 * BRSETB BSR UPKACCM SUPPLIED VALUE CMPI.B #1,D0 ADDRESS BEQ TYPEERROR CMPI.B #3,D0 ALPHA BEQ.S BRSETC BSR LSIZE MAKE IT LONG BRSETB1 MOVEA.L (SP)+,A0  KILL ALL BRKILLA CLR.B (A0) ADDA.L #IMSIZE,A0 CMPA.L IMLAST,A0 BNE BRKILLA RTS BRKILLB BSR FINDACBR BNE.S *+4 CLR.B (A0) RTS * BRACT BSR GETLNA ACTIVATE BREAKS TST D0 BNE.S BRACTC MOVEA.L IMFIRST,A0 BRACTA TST.B RECOVER POINTER MOVE.B #$FF,(A0)+ FLAG AS COUNT MOVE.L ACCUMD,(A0)+ MOVE VALUE RTS BRSETC MOVEA.L (SP)+,A1 RECOVER POINTER CMP.B -1(A1),D1 WILL IT FIT ? BHI SIZEERROR MOVE.B D1,(A1)+ PUT SIZE BRA.S BRSETE BRSS RTS * FINDACBR EQU * ACCUM HAS BR REF * FIND THE BR MOVEA.L IMFIRST,A0 BSR.S FINDBRV FINDBRA CMP.L 2(A0),D2 VALUE COMPARE CHG32 BEQ.S FINDBRC CHG32 FINDBRB ADDA.L #IMSIZE,A0 CHG32 CMPA.L IM (A0) BEQ.S BRACTB BSET #4,(A0) BRACTB ADDA.L #IMSIZE,A0 CMPA.L IMLAST,A0 BNE BRACTA BRARET RTS BRACTC BSR FINDACBR BNE BRARET BSET #4,(A0) RTS * BRDAC BSR GETLNA DEACTIVATE BREAKS TST D0 BNE.S BRDACC BRDACALAST,A0 CHG32 BNE FINDBRA CHG32 ANDI #$FFF0,SR CHG32 SET NE IN CCR FINDRET RTS CHG32 FINDBRV CMPI.B #1,ACCUMT CHG32 GET VALUE IN D2 BNE.S FINDBR1 CHG32 MOVE.L ACCUMD,D2 CHG32 RTS MOVEA.L IMFIRST,A0 BRDACB BCLR #4,(A0) ADDA.L #IMSIZE,A0 CMPA.L IMLAST,A0 BNE BRDACB BRDRET RTS BRDACC BSR FINDACBR BNE BRDRET BCLR #4,(A0) RTS * BRERRM DC.B 'DUPLICATE BREAK',0 BRERR LEA BRERRM,A0 BRA ESCAPE * CHG32 FINDBR1 MOVEQ #0,D2 CHG32 MOVE.W ACCUMD,D2 CHG32 RTS CHG32 FINDBRC MOVE.B ACCUMT,D2 CHG32 CMPI.B #1,D2 CHG32 ADDRESS BEQ.S FINDBRD CHG32 MOVE.B #2,D2  BRSET BSR GETLNA SET BREAKPOINT TST D0 BEQ SYNTAXE BTST #2,DSTATUS GT or TT ? BEQ.S BRSET0 BSR FINDACBR WATCH FOR DOUBLE BEQ BRERR MOVEA.L IMFIRST,A0 BRA BRSETA USE TABLE ENTRY 0 * BRSET0 BSR FINDA CHG32 LINE # FINDBRD OR.B (A0),D2 CHG32 CMP.B (A0),D2 CHG32 BEQ FINDRET CHG32 BSR FINDBRV CHG32 BRA FINDBRB CHG32 * * DUMP ONE BREAK POINT * OUTBR MOVE.L A0,-(SP) SAVE POINTCBR LOOK IN TABLE BEQ.S BRSETA * FIND EMPTY TABLE ENTRY MOVEA.L IMFIRST,A0 FINDBR0 ADDA.L #IMSIZE,A0 CMPA.L IMLAST,A0 BEQ.S BRFULL TST.B (A0) BNE FINDBR0 BRA.S BRSETA BRFULL LEA BRFULLM,A0 BRA ESCAPE BRFULLM DC.BER MOVE.B #'A',D0 BTST #4,(A0) BNE.S OUTBR0 MOVE.B #'D',D0 OUTBR0 BSR OUTBYTE BSR OUTBLANK BTST #0,(A0) LINE OR ADDRESS BEQ.S OUTBRA MOVEQ #4,D1 CHG32 ADDQ.L #2,A0 4/9/85 JWS FIX BKPT DISP BSR OU 'BR TABLE FULL',0 BRSETA CMPI.B #1,D0 BEQ.S BRSETA1 MOVE.W #$1200,(A0)+ MOVE.W #0,(A0)+ CHG32 MOVE.W ACCUMD,(A0)+ LINE NUMBER BRA.S BRSETA2 BRSETA1 BTST #0,ACCUMD+3 DON'T ALLOW ODD BNE ADDRERROR MOVE.W #$1100,(A0)+TADDR BRA.S OUTBRB OUTBRA MOVEQ #2,D1 ADDQ.L #4,A0 CHG32 BSR OUTUINT OUTBRB BSR OUTBLANK MOVEA.L (SP),A0 RECALL THE POINTER LEA 9(A0),A0 CHG32 CMPI.B #$FF,(A0) BEQ.S OUTBRC MOVEQ #0,D1 COMMAND BREAK MOV CHG32 MOVE.L ACCUMD,(A0)+ CHG32 MEMORY ADDRESS BRSETA2 ADDQ.L #3,A0 SKIP CODE & MAX SIZE MOVE.L A0,-(SP) BSR GETGVALUE COUNT/COMMAND TST.B ACCUMT BNE.S BRSETB CLR.L ACCUMD DEFAULT COUNT 0 BTST #2,DSTATUS TT or G:     ETD MOVE.B (A0)+,(A1)+ MOVE THE STRING BRSETE DBRA D1,BRSETD RTS PAGE * K0..K9 COMMANDS * UDKCMDS EQU * ANDI.W #$000F,D0 GET DIGIT MOVE.W D0,D1 SAVE DIGIT MULU #6,D0 LEA K0DATA,A0 ADDA.L D0,A0  D0,TEMPL2 DOWN ADDRESS BRA OPENC * OPENE BSR A0A23 CONVERT A0 TO A2 A3 BSR PUSHIN LEA BLANK,A2 PUT LEADING BLANK LEA 1(A2),A3 SO GETGVALUE WILL BSR GETGVALUE PICK UP THE DATA TST.B ACCUMT BEQHAVE ^ TO INFO VECTOR MOVE.L A0,-(SP) SAVE I.V. POINTER MULU #UDKSIZE,D1 MOVEA.L KDATAP,A0 ADDA.L D1,A0 HAVE DATA AREA POINTER MOVE.L A0,-(SP) SAVE D.A. POINTER * BSR GETGVALUE TST.B ACCUMT BNE.S UDKC_A MOVEA.L (SP)+, OPRET NO DATA SO DONE BSR.S OPENASG ASSIGN THE DATA BRA OPENC DO NEXT PROMPT * OPENASG EQU * ASSIGN ACCUM TO MEMORY BSR UPKACCM CMPI.B #3,D0 ALPHA ? BNE.S OPENA_E * ASSIGN ALPHA MOVEA.L TEMPL2,A1 DEST ADDA0 SKIP D.A. POINTER MOVEA.L (SP)+,A0 POP I.V. POINTER BSR OUTINFO PRINT INFO BRA OUTEOL * UDKC_A BSR AFETCH FETCH DATA IF ADDRESS BSR UPKACCM UNPACK ACCUMULATOR CMPI.B #UDKSIZE,D1 CHECK SIZE BHI SIZEER BRA.S OPENA_B OPENA_A MOVE.B (A0)+,(A1)+ OPENA_B DBRA D1,OPENA_A * ADJUST THE DESTINATION ADDRESS MOVE.L A1,D0 CMPI.B #1,TEMPL+3 BYTES ? BEQ.S OPENA_D BTST #0,D0 WORD or LONG BEQ.S OPENA_C ADDQ.L #1,D0 EVEN ADDRESS ORROR MOVEA.L (SP),A1 RECALL D.A. POINTER MOVE.L D1,D2 COPY SIZE BRA.S UDKC_C UDKC_B MOVE.B (A0)+,(A1)+ MOVE THE DATA UDKC_C DBRA D2,UDKC_B MOVEA.L (SP)+,A0 POP D.A. POINTER MOVEA.L (SP)+,A1 POP I.V. POINTER BSET #7,D0 PENA_C CMPI.B #4,TEMPL+3 LONG ? BNE.S OPENA_D BTST #1,D0 BEQ.S OPENA_D ADDQ.L #2,D0 OPENA_D MOVE.L D0,TEMPL2 SAVE ADDRESS RTS OPENA_E BSR AFETCH IF ADDRESS GET 4 BYTES CMPI.B #1,TEMPL+3 BNE.S OPENA_F BSR SIZE1 MAK MARK INDIRECT MOVE.B D0,(A1)+ TYPE MOVE.B D1,(A1)+ SIZE MOVE.L A0,(A1) ADDRESS RTS PAGE * OPEN MEMORY FOR CHANGES FROM KEYBOARD * OSIZES DC.B 'L@WB@' OPENCMD LEA OSIZES,A0 MOVEQ #4,D2 OPCMDA CMP.B (A0)+,DE BYTE SIZE MOVEA.L TEMPL2,A1 MOVE.B ACCUMD,(A1)+ BRA.S OPENA_H OPENA_F CMPI.B #2,TEMPL+3 BNE.S OPENA_G BSR SIZE2 MAKE WORD SIZE MOVEA.L TEMPL2,A1 MOVE.W ACCUMD,(A1)+ BRA.S OPENA_H OPENA_G BSR SIZE4 MAKE LONG SIZE MOVEA.L TEMP0 DBEQ D2,OPCMDA BNE WHATERR OPENA MOVE.L D2,TEMPL SAVE SIZE BSR GETADDR GET ADDRESS CMP.L TEMPL,D0 CHECK SIZE BEQ.S OPENB BTST #0,3(A0) MUST BE EVEN BNE ADDRERROR ADDRESSING ERROR OPENB L2,A1 MOVE.L ACCUMD,(A1)+ OPENA_H MOVE.L A1,TEMPL2 RTS * OPENP EQU * OPEN PROMPT MOVEQ #4,D1 LEA TEMPL2,A0 BSR OUTADDR PROMPT WITH ADDR BSR OUTBLANK * SET DEFAULT FORMAT SPECS MOVE.B DSCODE,ACCUMT MOVE.B MOVE.L (A0),TEMPL2 SAVE ADDRESS BSR GETGVALUE ANY DATA ? TST.B ACCUMT BEQ.S OPENC BSR.S OPENASG DO ASSIGN THEN DONE OPRET RTS OPENC EQU * PROMPT FOR DATA TO ASSIGN BSR OPENP ISSUE PROMPT BSR PDINPUT INPUT DATA TEMPL+3,ACCUMS MOVEA.L TEMPL2,A0 CMPI.B #1,ACCUMS BNE.S OPENP_A MOVE.B (A0),ACCUMD BRA.S OPENP_C OPENP_A CMPI.B #2,ACCUMS BNE.S OPENP_B MOVE.W (A0),ACCUMD BRA.S OPENP_C OPENP_B MOVE.L (A0),ACCUMD OPENP_C BSR PUSHIN LEA BLANK,ABTST #5,DSTATUS CONTINUE/STEP ? BNE OPRET BCLR #2,DSTATUS2 BEQ.S OPENE BSR OUTEOL MOVE.L TEMPL,D0 GET SIZE BTST #3,DSTATUS2 UP/DOWN ? BEQ.S OPEND ADD.L D0,TEMPL2 UP ADDRESS BRA OPENC OPEND SUB.L 2 MAKE BLANK FORMAT LEA 1(A2),A3 BSR FORMAT PROMPT WITH DATA VALUE BRA OUTBLANK PUT BLANK & DO RTS PAGE * EXECUTE THRU CURRENT PROC. * PROCCMD MOVE.L REGA6,OLDA6 BCLR #6,DSTATUS2 CLEAR TRACE BIT BSR T0NORM:     EADER ? BEQ.S WDUMPA MOVEQ #0,D0 SUBQ.L #1,A0 SKIP FLAG BYTE MOVE.B -(A0),D0 GET NAME SIZE SUBA.L D0,A0 FRONT OF NAME SUBQ.L #2,A0 FRONT OF LINE # LEA WFMT1,A2 LEA WFMT2E,A3 BRA.S WDUMPB WDUMPA LEA WFMT2 #2,A1 TRY FOR LONG ABS CMPI.W #$4EB9,(A1) JSR Long Abs BNE ERRORX MOVEA.L 2(A1),A0 GET ENTRY ADDR WPROCC MOVE.L A1,TEMPL3 SAVE JSR ADDR MOVEA.L A0,A1 CHECK FOR HEADER MOVEQ #0,D0 MOVE.B -(A1),D0 CMPI.B #2,D0 MUST ,A2 LEA WFMT2E,A3 WDUMPB MOVE.W #$0104,ACCUMT MOVE.L A0,ACCUMD BSR FORMAT DUMPIT BSR FINDNP CLEAN UP INPUT BSR WPROC FIND PROC HEADER AGAIN TST.W TEMPL2 STATIC LINK ? BEQ.S WDUMPB1 MOVEA.L SFA6,A0 ADDQ.L #8,A0 MOVE.L BE 0 OR 1 BCC.S WPROCX MOVE.B -(A1),D0 SIZE BEQ.S WPROCD GO CHECK STATIC LINK SUBA.L D0,A1 SHOULD BE AT FRONT OF NAME MOVE.B (A1),D0 GET STRING SIZE ADDA.L D0,A1 ADDQ.L #3,A1 CMPA.L A0,A1 SHOULD BE SAME BNE.S WPROCX NOT.B  NORMAL TRAP0 OPS CMPI.B #' ',D0 BEQ.S PROCXIT CMPI.B #'X',D0 BEQ.S PROCXIT CMPI.B #'N',D0 BNE WHATERR BSET #4,LTFLAGS SET NEXT PROC FLAG PROCXIT BSET #5,LTFLAGS SET EXIT PROC FLAG BRA GOUSER PAGE * ST (A0),ACCUMD LINK BSR PUSHIN LEA WFMT3,A2 ADDRESS OF FORMAT LEA WFMT3E,A3 BSR FORMAT BSR FINDNP CLEAN UP WDUMPB1 BSR PUSHIN LEA WFMT5,A2 LEA WFMT5E,A3 MOVE.L TEMPL,ACCUMD RETURN ADDRESS BEQ.S WDUMPACK FRAME COMMANDS * * RESET STACKFRAME POINTER * WRCMD MOVE.L REGA6,SFA6 BCLR #0,SFA6+3 FORCE EVEN ADDR RTS * * WALK BACK THRU DYNAMIC LINKS * WCMD EQU * BSR.S WSTART BEQ.S WCMDX A5=(A6) SO NOW IN MAIN PROG MOVEA.B5 LEA WFMT4,A2 LEA WFMT4E,A3 WDUMPB2 BSR FORMAT BSR FINDNP CLEAN UP * MOVEA.L SFA6,A0 TEMP WALK BACK MOVE.L A0,-(SP) MOVE.L (A0),SFA6 * DOES CALLER HAVE DEBUG ON ? BSR.S WPROC MOVE.L (SP)+,SFA6 RESTL SFA6,A0 MOVE.L (A0),SFA6 UNLINK A6 BSR WDUMP DUMP THE CALLER WCMDX RTS WSTART MOVEA.L SFA6,A0 CHECK MOVEA.L REGUS,A1 USER BTST #5,REGSR USER OR SYSTEM STACK ? BEQ.S WSCHK MOVEA.L REGA7,A1 SYSTEM * ORE POINTER BCLR #7,DSTATUS CLEAR ERROR TST.W TEMPL2+2 DEBUG ON ? BEQ.S WDUMPBX BSR.S WPROC REPOSITION MOVEA.L TEMPL3,A1 GET JSR ADDR LEA -2(A1),A1 WDUMPB3 CMPI.W #$4E40,-(A1) TRAP 0 ? BEQ.S WDUMPB4 CM SP MUST BE < A6 WSCHK CMPA.L A1,A0 BLT.S NOTCOMP BSR WDUMP DUMP CURRENT PROC INFO BCLR #7,DSTATUS BNE.S NOTCOMP MOVEA.L G_DOLLAR,A1 MOVEA.L SFA6,A0 CMPA.L (A0),A1 RTS * NOTCOMP LEA NOTCOMPM,A0 BRA ESCAPE NOTCOPA.L A1,A0 PAST HEADER ? BNE WDUMPB3 WDUMPBX RTS WDUMPB4 MOVE.L A1,ACCUMD ADDR OF TRAP0 BSR PUSHIN DUMP CALLING LINE NO. LEA WFMT6,A2 LEA WFMT6E,A3 WDUMPB5 BRA FORMAT * FIND CURRENT PROC HEADER WPROC MOVEAMPM DC.B 'NON STANDARD CALL',0 WFMT1 DC.B 'U2,S,2>,/,' WFMT2 DC.B '"PROC ADDRESS ",*,/ ' WFMT2E EQU * WFMT3 DC.B '"STATIC LINK ",*,/ ' WFMT3E EQU * WFMT4 DC.B '"CALLED FROM ",*,/ ' WFMT4E EQU * WFMT5 DC.B '"CALLE.L SFA6,A0 MOVEA.L G_DOLLAR,A1 CLR.L TEMPL RETURN ADDRESS CLR.L TEMPL2 STATIC LINK & DEBUG HDR CMPA.L (A0),A1 BNE.S WPROCA MOVEA.L INITPC,A0 MAIN LINE BRA.S WPROCC * WPROCA MOVEA.L 4(A0),A1 GET RETURN ADDR D FROM SYSTEM",/ ' WFMT5E EQU * WFMT6 DC.B '" LINE ",2>,U2,/ ' WFMT6E EQU * * WDUMP BSR PUSHIN SAVE INPUT PTRS BSR WPROC FIND PROC HEADER BCLR #7,DSTATUS ERROR ? BNE NOTCOMP TST.W TEMPL2+2 DEBUG HMOVE.L A1,TEMPL BTST #0,TEMPL+3 DON'T ALLOW ODD ADDRESS BNE ERRORX LEA -4(A1),A1 FIND JSR CMPI.W #$4EBA,(A1) JSR PC rel BNE.S WPROCB MOVEA.W 2(A1),A0 LEA 2(A1,A0),A0 GET ENTRY ADDR BRA.S WPROCC WPROCB SUBQ ;      TEMPL2+2 HAS DEBUG HEADER WPROCD CMPI.B #1,-1(A0) BNE.S WPROCX NOT.B TEMPL2 HAS STATIC LINK WPROCX RTS ADDRERROR LEA ADDRERRM,A0 BRA ESCAPE ADDRERRM DC.B 'ADDRESS ERROR',0 PAGE * * WALK BACK STATIC LINKS * WSCMD  #3,D0 ALPHA TYPE ? BNE.S TDCMDA MOVEA.L A0,A2 MAKE POINTERS MOVEA.L A2,A3 ADDA.L D1,A3 BRA.S SNEWCMD TDCMDA LEA ONLYK,A2 LEA ONLYKE,A3 * SNEWCMD BSR PUSHIN START NEW COMMAND LEA SEMIC,A2 LEA SEMIC+1,A3 RTS SEMIC DEQU * BSR WSTART BEQ WPROCX A5=(A6) SO NOW IN MAIN PROG * FOLLOW STATIC LINK BSR WPROC BCLR #7,DSTATUS ERROR ? BNE NOTCOMP TST.W TEMPL2+2 DEBUG HEADER ? BEQ.S NOSTATIC TST.W TEMPL2 C.B ';' ONLYK DC.B 'K4' ONLYKE EQU * * DAGCMD EQU * DUMP ALPHA/DUMP GRAPHICS COMMANDS BTST #5,REGSR ALLOWED ONLY IF USER MODE BNE.S NAERR CMPI.B #'A',D0 BEQ.S DACMD CMPI.B #'G',D0 BNE WHATERR MOVEQ #3,D0 STATIC LINK ? BEQ.S NOSTATIC MOVEA.L SFA6,A0 FOLLOW STATIC LINK MOVE.L 8(A0),SFA6 BRA WDUMP DUMP THE CALLER NOSTATICM DC.B 'NO STATIC LINK',0 NOSTATIC LEA NOSTATICM,A0 BRA ESCAPE PAGE * TRACE --- SINGLE STEP CPU INSTRUCTI DUMP GRAPHICS COMMAND BRA.S DAGCMD1 DACMD MOVEQ #2,D0 DUMP ALPHA COMMAND DAGCMD1 BRA SYSCALL NAERRM DC.B 'NOT ALLOWED NOW',0 NAERR LEA NAERRM,A0 BRA ESCAPE TTL PARSER UTILITIES PAGE * DEBUGGER PARSER UTILITIES * GETCOUNONS * TCMD BSET #6,DSTATUS2 SET TRACE BIT BSET #2,DSTATUS SET GO BIT ANDI.B #$80,TFLAGS LEAVE QUEUE ORI.B #$03,TFLAGS SET TD & STOP BSR T0NORM NORMAL TRAP 0 CMPI.B #' ',D0 BEQ.S TCMDA CMPI.B #'Q',D0 BEQ.S TCMT BSR.S GETGVALUE BSR UPKACCM CMP.B #1,D0 CAN'T ALLOW ADDRESS BEQ TYPEERROR TST.B D0 SKIP NULL INPUT BNE LSIZE RTS GETGVALUE EQU * INGVALUE BSR FINDNP GVALUE EQU * GENERAL VALUE ' " OR LOCATION CLR.B ACCUMT EMDB CMPI.B #'T',D0 BEQ.S TCMDC BRA WHATERR * TCMDA BSR GETCOUNT COUNT OR NOTHING BEQ GOUSER CONDITION SET BY GETCOUNT MOVE.L ACCUMD,TCOUNT BSET #2,TFLAGS SET COUNT FLAG BRA.S TCMDD CLEAR STOP FLAG * PTY ACCUMULATOR BSR IFTERM BEQ.S GVEXIT CMPI.B #34,(A2) BEQ.S GVALA CMPI.B #39,(A2) BEQ.S GVALA BRA.S LOCATION * GVALA MOVE.B (A2)+,D0 MOVE.L A2,ACCUMD START ADDRESS MOVEQ #0,D1 COUNTER GVALB BSR IFEOI BEQ SY TQ COMMAND TCMDB BCLR #0,TFLAGS CLEAR TD REQUEST BSR IFTERM BEQ GOUSER CMPI.B #' ',(A2) BNE WHATERR BRA TCMDA GET COUNT THEN GO * TT COMMAND TCMDC BCLR #0,TFLAGS CLEAR TDNTAXE CMP.B (A2)+,D0 BEQ.S GVALC ADDQ.B #1,D1 BRA GVALB GVALC MOVE.B #$83,ACCUMT ALPHA TYPE MOVE.B D1,ACCUMS SIZE GVEXIT RTS LOCATION EQU * LEA OPSTACKE,A0 CLEAR OP STACK MOVE.L A0,OPSTACK CLR.W ACCUMT  REQUEST BSR IFTERM BEQ GOCMDC CMPI.B #' ',(A2) BNE WHATERR * BSR BRSET SET BREAK POINT TCMDD BCLR #1,TFLAGS CLEAR STOP FLAG BRA GOUSER * * TRACE DISPLAY COMMAND * TDCMD BSR FINDNP TD or TD I BE NULL ACCUMULATOR CLR.L ACCUMD BSR.S IFLTERM CHECK FOR END OF LOCATION BEQ.S LOC_RET MOVE.W #$0204,ACCUMT ZERO ACCUMULATOR CLR.B DATAT MARK DATA EMPTY BSR EXPRESSION BSR.S IFNOP BNE SYNTAXE BSR.S IFLTERM BNE SYNTAXE LQ.S DOTDCMD IF END OF COMMAND THEN IS SIMPLE TD CMPI.B #'I',(A2)+ BSR FINDNP BNE SYNTAXE BRA DINITK4 SET K4 (TD) TO INITIAL VALUE DOTDCMD BSR PUSHIN INSERT COMMAND FROM K4 LEA K4DATA,A0 BSR UPKINFO CMPI.B OC_RET RTS * * CHECK FOR END OF LOCATION PARAM IFLTERM BSR IFEOI BEQ.S TERMEND IFLT_0 CMPI.B #' ',(A2) PARAM BEQ.S TERMEND CMPI.B #':',(A2) FORMAT BEQ.S TERMEND CMPI.B #';',(A2) COMMAND TERMEND RTS * PUSHOP MOVEA;     0 CMPI.B #'<',D0 IS IT RELATIONAL OP ? BCS.S ROPXIT BSR IFLTERM MAY HAVE 2nd CHAR BEQ SYNTAXE CMPI.B #'=',D0 BEQ.S ROPXIT CMPI.B #'<',D0 BEQ.S ROP2 CMPI.B #'>',D0 BNE.S ROPXIT ROP0 CMPI.B #'=',(A2) HA) MOVEM.L (SP)+,D0-D7/A5 RTS * DIVERR LEA DIVMSG,A0 BRA ESCAPE DIVMSG DC.B 'DIVIDE BY ZERO',0 SYSSET MOVE.L (SP)+,TEMPL3 SAVE RETURN MOVEM.L D0-D7/A5,-(SP) MOVEA.L G_DOLLAR,A5 MOVE.W escapecode(A5),-(SP) SWITCH RECOVER VE > CHECK FOR = BNE.S ROPXIT ROP1 LSL.W #8,D0 SHIFT THE FIRST CHARACTER MOVE.B (A2)+,D0 PICK UP THE SECOND ROPXIT RTS ROP2 CMPI.B #'>',(A2) CHECK FOR <> BEQ ROP1 BRA ROP0 CHECK FOR <= * DATA_ACC M (scs) MOVE.L recoverblk(A5),-(SP) (scs) PEA OPERR MOVE.L SP,recoverblk(A5) (scs) RECEXIT MOVEA.L TEMPL3,A0 JMP (A0) * OPERR MOVE.L (SP)+,recoverblk(A5) RES.L OPSTACK,A0 CMPA.L #OPSTACK+4,A0 BEQ.S CMPLEXE OVERFLOW MOVE.W D0,-(A0) PUSH OPERATOR CLR.W -(A0) FLAG AS OPERATOR MOVE.L A0,OPSTACK RTS * CPLEXM DC.B 'EXPRESSION TOO COMPLEX',0 CMPLEXE LEA CPLEXM,A0 BRA ESCAPE * POPOP BSROVE.L DATAT,ACCUMT MOVE.L DATAD,ACCUMD RTS * FETCH DATA POINTED TO BY ADDRESS TYPE AFETCH BSR UPKACCM CMPI.B #1,D0 ADDRESS ? BNE.S AEXIT BSR LSIZE REMOVE ANY INDIRECT MOVE.B DSCODE,ACCUMT SET TO DEFAULT TYPE BSET #7,ACCU.S IFNOP BEQ SYNTAXE UNDERFLOW TST.W (A0)+ BNE SYNTAXE NOT OPR. MOVE.W (A0)+,D0 GET OPR. MOVE.L A0,OPSTACK RTS * IFNOP MOVEA.L OPSTACK,A0 CMPA.L #OPSTACKE,A0 RTS * POPACC BSR IFNOP BEQ SYNTAXE UNDERFLOW TSMT SET INDIRECT BSR LSIZE FETCH DATA AEXIT RTS * ACC_OP_DATA EQU * ACC<=ACC OP DATA * ACC<=DATA BSR POPOP TST.B D0 BEQ DATA_ACC DO ASSIGNMENT MOVE.W D0,-(SP) SAVE OP BSR AFETCH GT.W (A0)+ BEQ SYNTAXE NOT DATA MOVE.W (A0)+,ACCUMT MOVE TYPE & SIZE MOVE.L (A0)+,ACCUMD GET DATA MOVE.L A0,OPSTACK RTS * PUSHACC MOVEA.L OPSTACK,A0 CMPA.L #OPSTACK+4,A0 BEQ CMPLEXE OVERFLOW MOVE.L ACCUMD,-(A0) CMPA.L #OPSTACKET DATA IF ADDRESS BSR LSIZE MAKE ACC. NUMERIC 4 BYTES BSR EXGAD EXCHANGE ACC AND DATA BSR AFETCH GET DATA IF ADDRESS BSR LSIZE MAKE SIZE 4 BSR EXGAD EXCHANGE ACC AND DATA MOVE.L DATAD,D0 MOVE.W (SP)+,D1 GET OPC+4,A0 BEQ CMPLEXE OVERFLOW MOVE.W ACCUMT,-(A0) MOVE.W #1,-(A0) FLAG AS DATA MOVE.L A0,OPSTACK RTS * ACC_DATA MOVE.W ACCUMT,DATAT MOVE.L ACCUMD,DATAD RTS * IFBINOP CMPI.B #'+',(A2) BEQ.S IFRET CMPI.B #'-',(A2) BEQ.S IFRET CMPODE CMP.B #'+',D1 BNE.S ACC_OP1 ADD.L D0,ACCUMD ADD BRA.S ACC_OVCHK ACC_OP1 CMP.B #'-',D1 BNE.S ACC_OP2 SUB.L D0,ACCUMD SUBTRACT ACC_OVCHK BVS OVERFE CHECK FOR OVERFLOW RTS * ACC_OP2 CMPI.B #'*',D1 BNE.S ACC_OP3 BSRI.B #'*',(A2) BEQ.S IFRET CMPI.B #'/',(A2) BEQ.S IFRET CMPI.B #'=',(A2) BEQ.S IFRET CMPI.B #'<',(A2) BEQ.S IFRET CMPI.B #'>',(A2) EXP_RET EQU * IFRET RTS * EXPRESSION EQU * BSR IFLTERM IF TERMINATOR BEQ SYNTAXE MOVEQ .S SYSSET MOVE.L ACCUMD,-(SP) MOVE.L D0,-(SP) JSR E@MPY BRA.S ACC_EXIT ACC_OP3 CMPI.B #'/',D1 BNE ACC_OP4 TST.L D0 BEQ.S DIVERR BSR.S SYSSET SETUP MOVE.L ACCUMD,-(SP) MOVE.L D0,-(SP) JSR E@DIV ACC_EXIT MOVE.L (SP)+,AC #0,D0 BSR PUSHOP ACC:=DATA EXP_A BSR VALUE BSR.S ACC_OP_DATA BSR IFLTERM BEQ EXP_RET CMPI.B #')',(A2) BEQ EXP_RET BSR IFBINOP BNE SYNTAXE BSR.S CHECKROP BSR PUSHOP BRA EXP_A * CHECKROP MOVE.B (A2)+,DCUMD MOVEA.L recoverblk(A5),SP (scs) ADDQ.L #4,SP POP RECOVER ADDRESS MOVE.L (SP)+,recoverblk(A5) RESTORE RECOVER (scs) MOVE.W (SP)+,escapecode(A5) (scs<     TORE NORMAL (scs) MOVE.W (SP)+,escapecode(A5) ERROR CONTROL (scs) BRA OVERFE OVERFLOW ERROR * ACC_OP4 CMPI.B #'N',D1 NEGATE BNE.S ACC_OP5 NEG.L D0 MOVE.L D0,DATAD BRA ACC_OP_DATA * _F BSR DATAD4 NEG.L DATAD BRA VALUE_E VALUE_F BSR PUSHOP PUT IT BACK * VALUE_G BSR DATAD4 MAKE DATA 4 BYTES MOVE.W #$0104,D1 MAKE IT ADDRESS TYPE CMPI.B #1,DATAT BNE.S VALUE_H IF ALREADY ADDRESS THEN MOVE.W #$8 RELATIONAL OPERATORS ACC_OP5 CMPI.W #'<=',D1 BNE.S ACC_OP6 CMP.L ACCUMD,D0 SGE D0 ACC_ROPEXIT NEG.B D0 CLR.L ACCUMD MOVE.B D0,ACCUMD+3 RTS ACC_OP6 CMPI.W #'>=',D1 BNE.S ACC_OP7 CMP.L ACCUMD,D0 SLE D0 BRA 104,D1 SET INDIRECT BIT VALUE_H MOVE.W D1,DATAT * CHECK FOR DATA REF BSR IFLTERM IF END LOCATION BEQ VALUE_D CMPI.B #'I',(A2) SIGNED INT BNE.S VALUE_I BSR.S VALUE_J BRA VALUE_D VALUE_I CMPI.B #'U',(AACC_ROPEXIT ACC_OP7 CMPI.B #'=',D1 EQUALITY BNE.S ACC_OP8 CMP.L ACCUMD,D0 SEQ D0 BRA ACC_ROPEXIT ACC_OP8 CMPI.W #'<>',D1 BNE.S ACC_OP9 CMP.L ACCUMD,D0 SNE D0 BRA ACC_ROPEXIT ACC_OP9 CMPI.B #'<',D1 BNE.S ACC_OP12) UNSIGNED INT BNE VALUE_D BSR.S VALUE_J MOVE.B #6,DATAT BRA VALUE_D * VALUE_J ADDQ.L #1,A2 BSR EXGAD BSR AFETCH GET THE DATA BSR EXGAD BSR IFLTERM BEQ SYNTAXE MOVE.B (A2)+,D0 BSR GETHEX DECODE THE D0 CMP.L ACCUMD,D0 SGT D0 BRA ACC_ROPEXIT ACC_OP10 CMPI.B #'>',D1 BNE SYNTAXE CMP.L ACCUMD,D0 SLT D0 BRA ACC_ROPEXIT * * GET SIGNED 4 BYTE INTEGER DATAD * DATAD4 BSR.S EXGAD BSR LSIZE * SWITIGIT BCLR #7,DSTATUS ERROR CHECK BNE SYNTAXE CMPI.B #4,D0 BGT SYNTAXE MOVE.B D0,DATAS RTS PAGE SYMBOL BSR IFLTERM BEQ SYNTAXE MOVE.B (A2),D0 CMPI.B #'0',D0 BCS.S SYMB_01 CMPI.B #'9',D0 BHI.S SYMB_00 BRA DCH DATA AND ACCUM EXGAD MOVE.W ACCUMT,-(SP) MOVE.L ACCUMD,-(SP) BSR DATA_ACC DATA TO ACCM MOVE.L (SP)+,DATAD MOVE.W (SP)+,DATAT RTS PAGE VALUE BSR IFLTERM BEQ SYNTAXE CMPI.B #'(',(A2) BNE.S VALUE_A ADDQ.L #1,A2 ECIMAL DECIMAL INTEGER SYMB_00 CMPI.B #'A',D0 BCS.S SYMB_01 CMPI.B #'Z',D0 BHI.S SYMB_01 BRA.S SPECSYM DEBUGGER SYMBOL SYMB_01 CMPI.B #'$',D0 BNE.S SYMB_02 ADDQ.L #1,A2 BRA HEXNUM HEX NUMBER SYMB_02 CMPI.B #'%',D0 BNE.S SYMB_03  HAVE (EXPRESSION) BSR PUSHACC BSR EXPRESSION BSR IFLTERM BEQ SYNTAXE CMPI.B #')',(A2)+ BNE SYNTAXE BSR ACC_DATA DATA:=ACC BSR POPACC ACC:=(STACK)+ BRA.S VALUE_D * VALUE_A BSR IFBINOP  ADDQ.L #1,A2 BRA OCTNUM OCTAL NUMBER SYMB_03 CMPI.B #'!',D0 BNE.S SYMB_04 ADDQ.L #1,A2 BRA BINNUM BINARY NUMBER SYMB_04 EQU * HOOK FOR OTHER SYMBOLS BRA TRY_SYS * SPECSYM BSR.S SCAN_SYM GET THE SYMBOL CMPI.B #2 CHECK +-*/ BNE.S VALUE_C CMPI.B #'+',(A2) SIGN CHECK BEQ.S VALUE_B THROW AWAY + CMPI.B #'-',(A2) BNE SYNTAXE MUST BE * OR / MOVEQ #'N',D0 SAVE - BSR PUSHOP VALUE_B ADDQ.L #1,A2 BRA VALUE * VALUE_C BSR SYMBOL ,DATAS CHECK THE SIZE BNE SYS_SYM MOVEA.L DATAD,A0 MOVE.B (A0)+,D0 MOVE THE SYMBOL LSL.W #8,D0 TO D0 MOVE.B (A0),D0 LEA SYMBOLS,A0 SPECS0 CMP.W (A0)+,D0 BEQ.S SPECS1 ADDQ.L #6,A0 TST.W (A0) BNE SPECVALUE_D BSR IFLTERM BEQ RETURNA CMPI.B #'^',(A2) BNE RETURNA ADDQ.L #1,A2 VALUE_E BSR IFNOP ANY THING ON STACK ? BEQ.S VALUE_G TST.W (A0) OPERATOR ? BNE.S VALUE_G BSR POPOP CHECK OP CMPI.B #'N',D0 BNE.S VALUES0 BRA.S SYS_SYM TRY SYSTEM SYMBOL TABLE SPECS1 MOVE.W (A0)+,DATAT TYPE AND SIZE MOVE.L (A0),DATAD DATA FIELD CMPI.B #128,DATAT NULL TYPE BNE.S SYMRET MOVE.B DSCODE,DATAT DEFAULT BSET #7,DATAT SET IND. BIT SYMRET RTS <      MOVE.B #4,DATAS 4 BYTES RTS * NOTSYM MOVEQ #0,D1 MOVE.B DATAS,D1 MOVEA.L DATAD,A0 BSR OUTALPHA LEA SYMNFM,A0 BSR OUTMSG BRA CMDIN NO MESSAGE ESCAPE * FSYS_5 ADDA.W D0,A1 PTR TO END OF SYMBOL MOVE.W A1,D0 BUMP T OVERFM,A0 BRA ESCAPE ERRORX BSET #7,DSTATUS SET ERROR FLAG RTS PAGE ****GETHEX*** GET HEX (BINARY VALUE FROM ASCII) * D0.B HAS ASCII CHAR RETURNS $0-$F BINARY * GETHEX ANDI.L #$FF,D0 STRIP OFF ALL BUT BYTE CMPI.B #$30,D0 IS IT LO EVEN ADDRESS ANDI.W #1,D0 ADDA.W D0,A1 MOVEQ #0,D0 MOVE.B 1(A1),D0 ADDA.W D0,A1 PTR:=PTR+SIZE OF GVR BRA FSYS_3 TRY NEXT SYMBOL * FSYS_6 MOVEA.L TEMPL3,A0 RESTORE MODP MOVEA.L (A0),A0 MODP:=MODP.LINK BRA FSYS_2 TRY NEXT ESS THAN ZERO BCS ERRORX CMPI.B #$39,D0 IS IT GREATER THAN 9 BGT.S GTHX2 GTHX1 ANDI.L #$F,D0 SAVE ONLY LAST NIBBLE OTHER 28 B RTS GTHX2 CMPI.W #10,BASE IS BASE GREATER THAN 10 BLE ERRORX ALLOWED ? CMPI.B #$41,D0 IS IT LESS THA PAGE * SCAN INPUT FOR A SYMBOL SCAN_SYM MOVE.L A2,DATAD SAVE START ADDRESS MOVEQ #0,D1 LENGTH COUNTER SCAN_0 BSR IFLTERM BEQ.S SCAN_1 BSR IFBINOP BEQ.S SCAN_1 BSR.S IFDELIM BEQ.S SCAN_1 ADDQ.B #1,D1 ADDQ.L #1,A2 MODULE PAGE ** DECODE A NUMBER * DECIMAL MOVE.W #10,BASE MOVEQ #2,D0 BRA.S GETNUM HEXNUM MOVE.W #16,BASE MOVEQ #4,D0 BRA.S GETNUM OCTNUM MOVE.W #8,BASE MOVEQ #16,D0 BRA.S GETNUM BINNUM MOVE.W #2,BASE MOVEQ #5,D0 GETNUM MOVE.B SCANNED CHAR BRA SCAN_0 SCAN_1 MOVE.B D1,DATAS START LOOKING BEQ SYNTAXE NULL SYMBOL RTS IFDELIM CMPI.B #'(',(A2) BEQ.S IFDRET CMPI.B #')',(A2) BEQ.S IFDRET CMPI.B #'^',(A2) IFDRET RTS * SYMNFM DC.B ' IS UNDEFINED SYMB D0,DATAT BSR.S GETNUM0 MOVE.B #4,DATAS SET SIZE TST.W TEMPL3 ANY DIGITS ? BNE.S GETNUMX CLR.B DATAT NULL VALUE GETNUMX MOVE.L D0,DATAD SET DATA RTS * GETNUM0 MOVEM.L D1-D7/A4-A6,-(SP) SAVE ALL GETNUM1 MOVEQ #0,D0 ROL',0 ** TRY TO FIND SYMBOL IN SYSTEM DEFS TRY_SYS CMPI.B #'&',D0 BNE.S SYS_SYM0 ADDQ.L #1,A2 SKIP & SYS_SYM0 BSR SCAN_SYM * * TRY TO FIND SYMBOL IN SYSTEM TABLE * SYS_SYM MOVEQ #0,D0 SET CONDITION CODE JSR SYMBOLHOOK GIVE HOESULTS IN D0 & D1 MOVE.L D0,D1 MOVE.W D0,TEMPL3 FLAG FOR CHARACTER HIT NXTNUM BSR IFLTERM SEE IF AT END OF BUFFER BEQ.S EXITGN MOVE.B (A2)+,D0 GRAB CHARACTER BSR.S GETHEX RETURNS WITH D0=BINARY BCLR #7,DSTATUS ERROR CHECK BEQ.S OK FIRST SHOT BNE IFDRET MOVEA.L G_DOLLAR,A0 MOVEA.L SYSDEFS(A0),A0 MODP:=SYSDEFS FSYS_2 MOVE.L A0,D0 BEQ.S NOTSYM END OF THE LIST ? FSYS_21 MOVEA.L DEFADDR(A0),A1 PTR:=MODP.DEFADDR MOVE.L A1,D7 TEMP:=DEFADDR+DEFSIZE ADD.L DEFSIZE(A0)NXTNUM0 * HIGH LEVEL WILL CHECK THE CHARACTER SUBQ.L #1,A2 BACK IT UP BRA.S EXITGN NXTNUM0 CMP.W BASE,D0 IS INPUT LARGER THAN BASE BPL.S BASERR MOVE.W #-1,TEMPL3 FLAG AS SOMETHING READ MOVE.L D1,D2 GET READY TO MULTIPLY D1*BASE SWAP ,D7 MOVE.L A0,TEMPL3 SAVE MODP FSYS_3 CMP.L A1,D7 IF A1<=D7 THEN NEXT MODULE BLE.S FSYS_6 * COMPARE SYMBOLS MOVEQ #0,D0 MOVE.B (A1)+,D0 CMP.B DATAS,D0 BNE.S FSYS_5 MOVEA.L DATAD,A0 RECALL ADDRESS SUB D1 MULU BASE,D1 TOP PART SWAP D1 TST.W D1 CHECK FOR OVERFLOW BNE.S OVERFE VALUE IS TOO LARGE MULU BASE,D2 NOW WORK ON LOW WORD ADD.L D2,D1 PUT IT BACK TOGETHER BVS.S OVERFE OVERFLOW ADD.L D0,D1 ADD IN NEW STUFQ.W #1,D0 FSYS_4 CMPM.B (A1)+,(A0)+ DBNE D0,FSYS_4 BNE.S FSYS_5 * SYMBOL FOUND MOVE.W A1,D0 BUMP PTR TO EVEN ADDRESS ANDI.W #1,D0 ADDA.W D0,A1 MOVE.L 2(A1),DATAD GET VALUE MOVE.B DSCODE,DATAT DEFAULT TYPE F BVS.S OVERFE ON OVERFLOW BRA NXTNUM EXITGN MOVE.L D1,D0 SET UP RESULT FOR RETURN MOVEM.L (SP)+,D1-D7/A4-A6 RESTORE ALL RTS BASERR LEA BASEM,A0 BRA ESCAPE BASEM DC.B 'BAD DIGIT',0 OVERFM DC.B 'OVERFLOW',0 OVERFE LEA =     N 'A' BCS ERRORX CMPI.B #$46,D0 IS IT GT 'F' BGT ERRORX SUBQ.B #7,D0 MAKE IT SMALLER A=10 BRA GTHX1 PAGE * DEBUGGER PRE-DEFINED SYMBOLS * * BIT 7 =1, MEANS THAT VALUE IS POINTER TO THE TYPE * SYMBOL TYPE CODE 0= EMPTY  'K2',8,4 DC.L K2DATA DC.B 'K3',8,4 DC.L K3DATA DC.B 'K4',8,4 DC.L K4DATA DC.B 'K5',8,4 DC.L K5DATA DC.B 'K6',8,4 DC.L K6DATA DC.B 'K7',8,4 DC.L K7DATA DC.B 'K8',8,4 DC.L K8DATA DC.B 'K9',8,4 DC.L  10 UNDEFINED * 1= ADDRESS 11 UNDEFINED * 2= SIGNED INTEGER 12 UNDEFINED * 3= ALPHA 13 UNDEFINED * 4= HEX  K9DATA DC.W 0 END OF SYMBOLS PAGE FINDNP BSR IFTERM FIND NEXT PARAMETER BEQ.S FPRET CMPI.B #' ',(A2)+ SKIP NON BLANKS BNE FINDNP FINDNP1 BSR IFTERM BEQ.S FPRET CMPI.B #' ',(A2)+ SKIP BLANKS BEQ FINDNP1  14 INSTRUCTION * 5= BINARY 15 REAL NUMBER * 6= UNSIGNED INTEGER 16 OCTAL NUMBER * 7= STRING 17 SPECIAL ( *  SUBQ.L #1,A2 BACK UP FPRET RTS * FINDCMD BSR IFTERM FIND END OF COMMAND BEQ FPRET MOVE.B (A2)+,D0 CMPI.B #39,D0 ' BEQ.S FINDCMD1 CMPI.B #34,D0 " BNE FINDCMD FINDCMD1 BSR IFEOI SKIP LITTERAL FIELDS BEQ  8= TYPE POINTER (POINTER TO DATA size type value) * 9= SPECIAL VALUE 18 SPECIAL ) * SYMBOLS DC.B 'PC',128,4 TYPE,SIZE DC.L REGPC VALUE DC.B 'SR',4+128,2 DC.L REGSR DC.B 'US',128,4 DC.L  FPRET CMP.B (A2)+,D0 BNE FINDCMD1 BRA FINDCMD TTL FORMAT INTERPRETER PAGE * FORMAT INTERPRETER *--------------------------------------- * ESCAPE TRAP MUST BE SET BEFORE CALLING * INFO TO DUMP IS IN ACCUMV * A2= INPUT SCANNER *  REGUS DC.B 'D0',128,4 DC.L DREGS DC.B 'D1',128,4 DC.L DREGS+4 DC.B 'D2',128,4 DC.L DREGS+8 DC.B 'D3',128,4 DC.L DREGS+12 DC.B 'D4',128,4 DC.L DREGS+16 DC.B 'D5',128,4 DC.L DREGS+20 DC.B 'D6',128,4 DC. POINTING TO JUST AFTER THE : * A3= END OF INPUT *--------------------------------------- * SETS UP * A4= DATA POINTER * A5= END OF DATA *--------------------------------------- * FORMAT EQU * LEA OPSTACKE,A0 CLEAR OPSTACK MOVE.L A0,OPSL DREGS+24 DC.B 'D7',128,4 DC.L DREGS+28 DC.B 'A0',128,4 DC.L AREGS DC.B 'A1',128,4 DC.L AREGS+4 DC.B 'A2',128,4 DC.L AREGS+8 DC.B 'A3',128,4 DC.L AREGS+12 DC.B 'A4',128,4 DC.L AREGS+16 DC.B 'A5',128,4TACK FOR USE IN REPEAT FORMAT GROUP BSR UPKACCM UNPACK ACCUMULATOR * RETURNS D0= TYPE * D1= SIZE * A0= DATA POINTER MOVE.L D1,SSIZE MOVE.B D0,SCODE DEFAULT TYPE MOVE.L A0,D3  DC.L AREGS+20 DC.B 'A6',128,4 DC.L AREGS+24 DC.B 'A7',128,4 DC.L AREGS+28 DC.B 'SF',128,4 DC.L SFA6 STACK FRAME DC.B 'SP',9,4 DC.L GETSP STACK POINTER DC.B 'LN',9,4 DC.L LNSPCL LINE NUMBER DC.B 'EC',9, SET START ADDR * AND.L #$00FFFFFF,D3 CLEAR HI BYTE/ CHG32 MOVEA.L D3,A4 START ADDR CMP.B #1,D0 ADDRESS TYPE ? BNE.S FMTO_0 MOVE.B DSCODE,SCODE DEFAULT SPEC MOVE.L #4,SSIZE DEFAULT SIZE BSR LSIZE * 4 DC.L ECSPCL ESCAPE CODE DC.B 'IO',9,4 DC.L IORSPCL IO RESULT DC.B 'GB',9,4 DC.L GBSPCL GLOBAL BASE DC.B 'RB',9,4 DC.L RBSPCL RELOCATION BASE * KSYMBOLS DC.B 'K0',8,4 DC.L K0DATA DC.B 'K1',8,4 DC.L K1DATA DC.B  CLR.B ACCUMD REMOVED FOR RODIO SFB/JWS 7/10/85 MOVEA.L ACCUMD,A4 START ADDR MOVEA.L #-1,A5 END ADDR CHG32 BRA.S FMTO_1 FMTO_0 MOVEA.L A4,A5 ADDA.L SSIZE,A5 END ADDR FMTO_1 EQU * * FMTO_2 MOVEQ #1,D0 MOVE.L =     ',(A2) IFFRT RTS * GETSIZE BSR IFFEND BEQ.S GETRET MOVE.W #10,BASE BSR GETNUM0 TST.L TEMPL3 ANYTHING READ ? BEQ.S GETRET TST.L D0 BEQ SYNTAXE RANGE CHECK IT MOVEA.L A4,A0 ADDA.L D0,A0 CMPA.L A5,A0 BHI.S BIGSC CHG #0,SSIZE+3 MAKE IT ODD {3.0 BUG #20 3/13/84} SSPEC0 CMP.L SSIZE,D1 GIVEN < ACTUAL ? BGT SIZEERROR MOVEA.L A4,A0 ADDA.L SSIZE,A4 BSR.S FMTERRC CHECK POSITION BSR OUTALPHA SUBQ.L #1,RCOUNT BEQ.S SPECRET MOVEQ #032 3/27/85 MOVE.L D0,SSIZE GETRET RTS BIGSC CMPA.L #-1,A5 ADDRESS MODE ? BEQ GETRET BIGSE LEA BIGSM,A0 BRA ESCAPE BIGSM DC.B 'SIZE FIELD TOO BIG',0 * * CHECK FOR FORMAT SPEC CHARACTER IFSPEC MOVE.B (A2),D0 LEA SPE,D1 MOVE.B (A4)+,D1 BSR.S FMTERRC CHECK POSITION BRA SSPEC0 * ARSPEC ADDA.L RCOUNT,A4 > SPEC BRA.S ADDRFMT CHECK POSITION * ALSPEC SUBA.L RCOUNT,A4 < SPEC ADDRFMT BSR.S INVC ADDRESS OBJECT ONLY BRA.S FMTERRC TRIM A4 * A D0,RCOUNT DEFAULT REPEAT BSR IFFEND END OF FORMAT ? BEQ FMTO_DUMP NO SPECS SO USE DEFAULT BSR IFSPEC FORMAT SPEC ? BEQ.S FMTO_3 MOVE.W #10,BASE REPEAT COUNT ? BSR GETNUM0 TST.L TEMPL3 ANYTHING READ ? BEQ CT,A0 MOVEQ #0,D1 IFSP0 CMP.B (A0),D0 BEQ.S IFSP1 ADDQ.L #2,D1 ADVANCE TABLE OFFSET TST.B (A0)+ BNE IFSP0 MOVEQ #-1,D0 RTS IFSP1 MOVEA.L D1,A0 ADDQ.L #1,A2 ADVANCE SCANNER MOVEQ #0,D0 RTS SPECT DC.B ' *IAHBUS^><',39 SYNTAXE TST.L D0 NON ZERO BEQ SYNTAXE MOVE.L D0,RCOUNT SET REPEAT COUNT BSR.S IFFEND END OF FORMAT ? BEQ FMTO_DUMP BSR IFSPEC FORMAT SPEC ? BNE SYNTAXE FMTO_3 MOVEA.W FMTTAB(A0),A0 JSR FMTTAB(A0) EXEC,34,'/XRO()',0 * NULSPEC RTS * ADRSPEC BSR INVC ADDRESS ONLY CHECK MOVEQ #4,D1 SIZE CHG32 MOVE.L A4,TEMPL2 DATA ADDR LEA TEMPL2,A0 CHG32 BSR OUTADDR BRA.S OUTBLANK * UFMT LEA OUTUINT,A1 UNSIGNED IUTE THE SPEC BSR IFTERM BEQ.S IFFRT BSR.S IFFEND MUST BE AT END OF SPEC BNE SYNTAXE CMPI.B #',',(A2) BNE RETURNA ADDQ.L #1,A2 MOVE.L #4,SSIZE RESET DEFAULT SIZE BRA FMTO_2 GET THE NEXT SPEC PAGE FMTTAB EQU * NT BRA.S IFMT0 * IFMT LEA OUTINT,A1 SIGNED INT IFMT0 BSR GETSIZE CMPI.L #4,SSIZE BGT BIGSE * FOUTLOOP MOVE.L SSIZE,D1 MOVEA.L A4,A0 ADDA.L D1,A4 WILL THIS BE TOO BIG BSR FMTERRC CHECK POSITION JSR (A1) BSR.S ODC.W NULSPEC-FMTTAB DC.W ADRSPEC-FMTTAB DC.W IFMT-FMTTAB SIGNED DECIMAL DC.W AFMT-FMTTAB ALPHA DC.W HFMT-FMTTAB HEX DC.W BFMT-FMTTAB BINARY DC.W UFMT-FMTTAB UNSIGNED DECIMAL DC.W SSPEC-FMTTAB STRING SPEUTBLANK MOVE.L SSIZE,D0 INC DATA POINTER SUBQ.L #1,RCOUNT BNE FOUTLOOP RTS * HFMT LEA OUTHEX,A1 HEX OUTPUT HFMT0 BSR GETSIZE BRA FOUTLOOP * OUTBLANK MOVEQ #' ',D0 BRA OUTBYTE OUTBYTE DOES RTS * BFMT C DC.W AISPEC-FMTTAB DC.W ARSPEC-FMTTAB DC.W ALSPEC-FMTTAB DC.W QSPEC-FMTTAB LITERAL SPEC DC.W Q2SPEC-FMTTAB DC.W NLSPEC-FMTTAB NEW LINE DC.W XSPEC-FMTTAB X REVERSE ASSEMBLE DC.W RSPEC-FMTTAB REAL NUMBER SPEC DC. LEA OUTBIN,A1 BINARY BRA HFMT0 * AFMT LEA OUTALPHA,A1 ALPHA BRA HFMT0 * SSPEC EQU * STRING SPECIFIER MOVEQ #0,D1 MOVE.B (A4)+,D1 GET ACTUAL SIZE BSR FMTERRC CHECK POSITION MOVE.L D1,SSIZE W OSPEC-FMTTAB OCTAL SPEC DC.W OPSPEC-FMTTAB OPEN PAREN SPEC DC.W CPSPEC-FMTTAB CLOSE PAREN SPEC * * CHECK END OF FORMAT SPEC IFFEND BSR IFTERM CHECK END OF COMMAND BEQ.S IFFRT CMPI.B #' ',(A2) BEQ.S IFFRT CMPI.B #', DEFAULT SIZE BSR GETSIZE GET SPECIFIED SIZE BNE.S SSPEC00 {3.0 BUG #20 3/13/84} CMPI.L #1,RCOUNT {3.0 BUG #20 3/13/84} BNE SYNTAXE {3.0 BUG #20 3/13/84} SSPEC00 BSET >     ISPEC BSR.S INVC ^ SPEC AISPEC1 MOVEQ #0,D0 CHG32 3/25/85 MOVE.B (A4)+,D0 CHG32 GET 4 BYTES LSL.L #8,D0 MOVE.B (A4)+,D0 LSL.L #8,D0 MOVE.B (A4)+,D0 LSL.L #8,D0 MOVE.B (A4)+,D0 MOVEA.L D0,A4 SUBQ.L #1,RCOUNT BEQ #2,D1 SIZE (WORD) LEA -2(A4),A4 DEW 10/21/88 FIX DEFECT FSDdt01674 MOVEA.L A4,A0 ADDRESS ADDA.L D1,A4 BSR OUTHEX BRA XSPECL * REAL NUMBER CONVERSION CALL RSPEC EQU * REAL NUMBER FORMAT MOVE.L A4NE AISPEC1 BRA.S FMTERRC TRIM A4 SPECRET RTS * Q2SPEC MOVEQ #34,D1 " BRA.S QSPEC0 QSPEC MOVEQ #39,D1 ' QSPEC0 BSR IFEOI CHECK FOR END OF INPUT BEQ SYNTAXE MOVE.B (A2)+,D0 CMP.B D1,D0 END ' BEQ SPECRET BSR OUT,TEMPL PUT OUTPUT ADDRESS IN TEMP AREA BTST #0,TEMPL+3 MUST BE EVEN ADDRESS BNE ADDRERROR MOVEQ #8,D1 BSR FMTERRC DO SIZE CHECK MOVEQ #4,D0 CALL SYSTEM CODE TO DO REAL TO STRING CONVERSION JSR SYSCALL MOVEA.L TEMPL,ABYTE BRA QSPEC0 * NLSPEC BSR OUTEOL NEW LINE SUBQ.L #1,RCOUNT BNE NLSPEC RTS * * FMTERRC TST.B (A4) BUG FIX 3.0 force bus error before syscall CMPA.L A5,A4 CHECK A4<=A5 BLE.S SPECRET * MOVE.L A4,-(SP) TRIM HIG4 ADDQ.L #8,A4 INCREMENT THE ADDRESS MOVEA.L TEMPL2,A0 MOVEQ #0,D1 GET THE STRING LENGTH MOVE.B (A0)+,D1 BSR OUTALPHA DUMP IT BSR OUTBLANK SUBQ.L #1,RCOUNT BNE RSPEC RTS * OCTAL NUMBER CONVERSION OSPEC EQU H BYTE CHG32 3/25/85 * CLR.B (SP) * MOVEA.L (SP)+,A4 CMPA.L #-1,A5 ADDRESS MODE CHG32 BEQ.S SPECRET LEA FMTEM,A0 BRA ESCAPE FMTEM DC.B 'FORMAT REQUIRES MORE DATA',0 * INVC CMPA.L #-1,A5 ADDRESS MODE ONLY* LEA OUTOCT,A1 BRA IFMT0 OPSPEC EQU * OPEN PAREN SPEC TST.W RCOUNT UPPER HALF MUST BE ZERO BNE SIZEERROR MOVE.L RCOUNT,D0 BSR PUSHOP PUSH COUNT ON OPSTACK CMPI.W #1,D0 BEQ.S OPSRET DON'T PUSH INPUT IF COUNT IS 1 BEQ.S SPECRET LEA INVCM,A0 BRA ESCAPE INVCM DC.B 'ADDRESS FORMAT NOT ALLOWED',0 * FMTO_DUMP MOVEQ #0,D0 DUMP USING DEFAULT SPEC MOVE.B SCODE,D0 LSL.L #1,D0 * 2 MOVEA.L D0,A0 GET SPEC ROUTINE ADDR BRA FMTO_3 PAGE *  BRA PUSHIN PUSH CURRENT POINTERS ON INPUT STACK * ( IT DOES RTS ) CPSPEC EQU * CLOSE PAREN SPEC MOVEQ #1,D0 CMP.L RCOUNT,D0 BNE SYNTAXE BSR POPOP POP COUNT FROM OPSTACK SUBQ.W #1,D0 BEQ.S OPSRE REVERSE ASSEMBLER CALL XSPEC EQU * MOVE.L A4,TEMPL PUT INSTRUCTION ADDRESS IN TEMP AREA BTST #0,TEMPL+3 MUST BE EVEN ADDRESS BNE ADDRERROR MOVEQ #2,D1 BSR FMTERRC DO SIZE CHECK CLR.L TEMPL3 MOVE.B DSCODE,TEMPL3+3 T IF COUNT WAS 1 THEN ALL DONE BSR PUSHOP PUT COUNT BACK BSR POPIN POP INPUT TO ORIGINAL BSR IFEOI CHECK END OF INPUT BEQ SYNTAXE CMPI.W #1,D0 BEQ.S OPSRET ALL DONE IF COUNT IS 1 BSR PUSHIN COPY INPUT POINTERS OPSRET PASS DEFAULT FORMAT CODE MOVEQ #5,D0 CALL SYSTEM CODE TO DO CONVERSION JSR SYSCALL MOVEA.L TEMPL,A4 GET THE NEW INSTRUCTION ADDRESS MOVEA.L TEMPL2,A0 GET THE STRING ADDRESS MOVEQ #0,D1 GET THE STRING LENGTH MOVE.B (A0)+,D1 RTS * INFO VECTOR INPUT/OUTPUT HANDLERS * AND CONVERSION UTILITIES * OUTINFO EQU * GIVEN INFO VECTOR IN A0 * OUTPUT THE DATA * OUTIF0 BSR UPKINFO D0=TYPE,D1=SIZE,A0=>DATA LSL.W #1,D0 * 2 MOVEA.L D0,A1 BEQ.S DODC IF NOT INSTRUCTION, STRING WILL BE NILL BSR OUTALPHA DUMP IT XSPECL BSR OUTBLANK SUBQ.L #1,RCOUNT BNE XSPEC RTS DCM DC.B 'DC.W ' IS DEFINE CONSTANT DODC LEA DCM,A0 MOVEQ #5,D1 BSR OUTALPHA MOV MOVEA.W OUTTYPE(A1),A1 JMP OUTTYPE(A1) * OUTTYPE EQU * DC.W RETURN-OUTTYPE EMPTY 0 DC.W OUTADDR-OUTTYPE ADDRESS 1 DC.W OUTINT-OUTTYPE INTEGER 2 DC.W OUTALPHA-OUTTYPE ALPHA 3 DC.W OUTHEX-OUTTYPE HEX 4 DC.W >     0 BSR OUTBYTE BRA.S OUTB2 OUTB1 MOVE.B (A0)+,D0 BSR.S BBOUT OUTB2 DBRA D1,OUTB1 RTS * BINARY BYTE OUT BBOUT MOVE.B D0,D3 MOVEQ #7,D2 BBOUT0 BTST D2,D3 BEQ.S BBOUT1 MOVEQ #'1',D0 BRA.S BBOUT2 BBOUT1 MOVEBASEPTR(A0),A0 BRA DEFWRD * GETSP EQU * * UNPACK STACK POINTER UNPSP LEA REGA7,A0 BTST #5,REGSR USER/SYSTEM BNE DEFWRD LEA REGUS,A0 BRA DEFWRD TTL FORMATTER BINARY TO DECIMAL PAGE * CONVERT BINAQ #'0',D0 BBOUT2 BSR OUTBYTE DBRA D2,BBOUT0 RTS * OCTAL OUTPUT D1 = SIZE A0^ DATA OUTOCT MOVEQ #'%',D0 BSR OUTBYTE MOVEQ #0,D2 UNSIGNED BRA.S OUTO2 OUTO1 ASL.L #8,D2 MOVE.B (A0)+,D2 OUTO2 DBRA D1,OUTO1 CLR.RY TO DECIMAL CALL OUTBYTE * TEMPL3 CONTAINS SIGN CHARACTER * TEMPL3+1 CONTAINS LEADING PAD CHARACTER * BIN2DEC MOVEM.L D1-D4/A0,-(SP) SAVE REGS MOVEA.L D5,A0 SAVE D5 FOR OUTBYTE USE MOVE.L D0,D5 SAVE VALUE HERE MOVEQ #10,D4 C OUTBIN-OUTTYPE BINARY 5 DC.W OUTUINT-OUTTYPE UINTEGER 6 * OTHER TYPES ARE RESOLVED BY UPKINFO * * ADDRESS OUTADDR CMPI.B #6,DSCODE BNE.S OUTADDR1 BSR.S OUTUINT UNSIGNED INTEGER BRA.S OUTADDR3 OUTADDR1 CMPI.B TEMPL3 CLEAR OUTPUT FLAG MOVEQ #10,D1 MAX DIGITS TO OUTPUT ROL.L #2,D2 ROTATE 2 HIGH BITS TO LOW END MOVE.L D2,D0 MOVE TO OUTPUT REG ANDI.L #3,D0 MASK OFF HIGH BITS BRA.S OUTO4 OUTO3 ROL.L #3,D2 ROTATE IN NEXT 3 BITS MOVE.L B #4,DSCODE BNE.S OUTADDR2 BSR.S OUTHEX HEX BRA.S OUTADDR3 OUTADDR2 BSR.S OUTINT SIGNED INTEGER OUTADDR3 MOVEQ #'^',D0 BRA OUTBYTE * SIGNED INTEGER OUTINT MOVE.B #' ',TEMPL3+1 LEADING BLANKS OUTINTS MOVEQ #0,D2 D2,D0 MOVE TO OUTPUT REG ANDI.L #7,D0 MASK OFF HIGH BITS OUTO4 BNE.S OUTO5 IF NON ZERO THEN DUMP IT TST.B TEMPL3 SUPPRESS LEADING ZEROES BEQ.S OUTO6 OUTO5 MOVE.B D0,TEMPL3 DID OUTPUT SOMETHING ADDI.L #48,D0 CHANGE TO ASCII D LEADING CHARACTER FLAG ALREADY SET MOVE.B #'+',TEMPL3 BTST #7,(A0) SIGNCHECK BEQ.S OUTI2 MOVEQ #-1,D2 BRA.S OUTI2 OUTINT1 ASL.L #8,D2 MOVE.B (A0)+,D2 OUTI2 DBRA D1,OUTINT1 TST.L D2 BPL.S OUTI3 MOVE.B #'-',TEMPL3 NEG.L IGIT BSR OUTBYTE OUTO6 DBRA D1,OUTO3 TST.B TEMPL3 BNE.S OUTO7 MOVE.B #'0',D0 OUTPUT AT LEAST ONE ZERO BSR OUTBYTE OUTO7 RTS TTL SPECIAL DATA ROUTINES PAGE * * SPECIAL ROUTINES FOR * LINE No. * I/O RESULT * ESCAPE CODD2 OUTI3 MOVE.L D2,D0 BRA BIN2DEC CONVERSION * OUTUINT MOVEQ #0,D0 UNSIGNED INTEGER MOVE.W #' ',TEMPL3 LEADING BLANKS BRA.S OUTU2 OUTU1 ASL.L #8,D0 MOVE.B (A0)+,D0 OUTU2 DBRA D1,OUTU1 BRA BIN2DEC CONVERSION * E * GLOBAL BASE * STACK POINTER * LNSPCL EQU * * UNPACK LINE NO. UNPKLN BRA GETLNUM * IORSPCL EQU * * UNPACK I/O RESULT UNPKIOR MOVEA.L REGA5,A0 LEA ioresult(A0),A0 (scs) BRA.S DEFW ALPHA OUTPUT OUTA1 MOVE.B (A0)+,D0 BSR OUTBYTE OUTALPHA DBRA D1,OUTA1 RTS * HEX OUTHEX MOVEQ #'$',D0 BSR OUTBYTE BRA.S OUTH2 OUTH1 MOVE.B (A0)+,D0 BSR.S HBOUT OUTPUT 2 DIGITS OUTH2 DBRA DRD * ECSPCL EQU * * UNPACK ESCAPE CODE UNPEC MOVEA.L REGA5,A0 LEA escapecode(A0),A0 (scs) MOVEQ #2,D0 SIGNED INT MOVEQ #2,D1 2 BYTES RTS * GBSPCL EQU * * UNPACK GLOBAL BASE POI1,OUTH1 RTS * HBOUT MOVE.B D0,D2 LSR.B #4,D0 BSR.S HBOUT1 MOVE.B D2,D0 HBOUT1 ANDI.B #$0F,D0 ORI.B #$30,D0 CMPI.B #$39,D0 BLE.S HBOUT2 ADDQ.B #7,D0 HBOUT2 BRA OUTBYTE * BINARY OUTPUT OUTBIN MOVEQ #'!',DNTER UNPGB MOVEA.L G_DOLLAR,A0 LEA GLOBALBASE(A0),A0 DEFWRD MOVEQ #0,D0 MOVE.B DSCODE,D0 DEFAULT TYPE MOVEQ #4,D1 4 BYTES RTS * RBSPCL EQU * * UNPACK RELOCATION BASE POINTER UNPRB MOVEA.L G_DOLLAR,A0 LEA R?     OUNTER MOVE.L #1000000000,D2 POWER OF TEN TST.L D5 BPL.S BIN2DC2 MOVEQ #1,D0 AT LEAST HAVE 1*10^10 BIN2DECA SUB.L D2,D5 HANDLE 2^31 .. 2^32-1 BPL.S BIN2DC22 ADDQ.B #1,D0 INC DIGIT BRA BIN2DECA BIN2DC0 MOVEQ #1,D2 VALUEQ #0,D0 MOVE.L D0,D1 MOVE.B (A0)+,D0 TYPE MOVE.B (A0)+,D1 SIZE * A0 POINTS TO DATA BCLR #7,D0 INDIRECT ? BEQ.S UPKI1 MOVEA.L (A0),A0 UPKI1 CMPI.B #7,D0 BLT.S UPKRET BNE.S UPKI2 MOVE.B (A0)+,E TO SUB MOVE.L D4,D1 COUNTER SUBQ.L #1,D1 ADJUST - FORM POWER OF TEN BEQ.S BIN2DC2 IF POWER IS ZERO BIN2DC1 MOVE.W D2,D3 D3 = LOWER WORD MULU #10,D3 SWAP D2 D2 = UPPER WORD MULU #10,D2 SWD1 CHANGE STRING TO ALPHA MOVEQ #3,D0 UPKRET RTS UPKI2 CMPI.B #14,D0 INSTRUCTION FORMAT BEQ UPKRET CMPI.B #15,D0 REAL NUMBER BEQ UPKRET CMPI.B #16,D0 OCTAL NUMBER BEQ UPKRET MOVEA.L (A0),A0 DATA IS POINTER CMP.B #8,D0 BEQAP D3 ADD UPPER TO UPPER ADD.W D3,D2 SWAP D2 PUT UPPER IN UPPER SWAP D3 PUT LOWER IN LOWER MOVE.W D3,D2 D2= UPPER & LOWER SUBQ.L #1,D1 BNE BIN2DC1 BIN2DC2 CLR.L D0 HOLDS SUB  UPKINFO TYPE POINTER JMP (A0) LET ROUTINE GET VALUE PAGE ** GET LINENUMBER D0=TYPE D1=SIZE A0=ADDRESS * GETLNUM MOVEQ #6,D0 DEFAULT UNSIGNED INT MOVEQ #4,D1 4 BYTES LEA TEMPL4,A0 CLR.L (A0) CLEAR LONG VALUE MOVEA.L LASTLIAMT BIN2DC22 CMP.L D2,D5 BLT.S BIN2DC3 IF NO MORE SUB POSSIBLE ADDQ.L #1,D0 BUMP SUBS SUB.L D2,D5 COUNT DOWN BY POWERS OF TEN BRA.S BIN2DC22 DO MORE BIN2DC3 TST.B TEMPL3 ANY VALUE? BEQ.S BIN2DC4 TST.NE,A1 CMPI.W #$4E40,(A1)+ CHECK FOR TRAP0 BNE.S GETLN2 MOVE.W (A1),2(A0) IS LINE NO. RTS GETLN2 MOVEQ #2,D0 SIGNED INT NOT.L (A0) -1 RTS TTL EXCEPTION HANDLER PAGE *------------------------------------------------ *-------B D0 BEQ.S BIN2DC6 MOVE.B D0,TEMPL3+2 START OF DATA MOVE.B TEMPL3,D0 GET SIGN BSR.S BINOUT MOVE.B TEMPL3+2,D0 CLR.B TEMPL3 MARK DATA STARTED BIN2DC4 ADD.B #$30,D0 BINARY TO ASCII BSR.S BINOUT BIN2DC5 SUBQ.L ----------------------------------------- * EXCEPTION HANDLER FOR PASCAL DEBUGGER *------------------------------------------------ *------------------------------------------------ * * TRAP 0 HANDLER * rdq NOV 81 * TRAP0 EQU * start of#1,D4 NEXT POWER BNE BIN2DC0 BIN2DCX MOVE.L A0,D5 RESTORE D5 MOVEM.L (SP)+,D1-D4/A0 RTS JUST END ROUTINE BIN2DC6 SUBQ.L #1,D4 BEQ.S BIN2DC7 MOVE.B TEMPL3+1,D0 GET LEADING CHARACTER BEQ BIN2DC0 NO LEADIN statement exception process MOVE #$2700,SR LOCKOUT INTERUPTS SUBQ.L #2,2(SP) BACKUP TO 4E40 MOVE.L 2(SP),LASTLINE save last line address ADDQ.L #4,2(SP) inc. PC past line # TST.B LTFLAGS anything to do ? BNE.S G CHARACTERS BSR.S BINOUT OUTPUT LEADING CHARACTER BRA BIN2DC0 * BINOUT EXG D5,A0 SWITCH IN D5 BSR OUTBYTE DUMP IT EXG D5,A0 SWITCH IT BACK RTS * BIN2DC7 MOVEQ #' ',D0 BSR BINOUT PRINT AT LEAST A ZTRAP0_0 RTE NO SO RETURN * TRAP0_0 MOVEM.L D5-D7/A0-A1,-(SP) save scratch regs BCLR #6,DSTATUS CLEAR CALL FLAG MOVEQ #0,D5 CLEAR IMPLANT FLAG MOVEQ #0,D7 clear FLAGS reg. MOVE.B LTFLAGS,D7 load reg. MOVEQ #7,D6 ERO MOVEQ #'0',D0 BSR BINOUT BRA BIN2DCX END OF ROUTINE TTL FORMATTER UTILITIES PAGE * GIVEN A0 POINTS TO INFO VECTOR * UNPACK TO D0=TYPE, D1=SIZE, A0 POINTS TO DATA * UPKACCM LEA ACCUMV,A0 UNPACK ACCUMULATOR UPKINFO MOVset bit pointer LEA TRAP0JV,A0 get jumptable address * TRAP0_1 BCLR D6,D7 test & clear the next bit BEQ.S TRAP0_2 MOVEA.L (A0),A1 JSR (A1) do the task * TRAP0_2 ADDQ.L #4,A0 next jump entry TST.B D7 all done ? DBEQ ?     == * T0CHKA6 CMPA.L OLDA6,A6 CHECK A6 BLS.S EXECRET MOVE.L #PROCEM,D5 SET COMMAND T0PXIT MOVEQ #0,D7 KILL REST OF TRAP 0 OPS EXECRET RTS PROCEM DC.B 17,'D "PROC EXITED";?' *======================== * T0NPROC CMPA.L OLDA6,A6  BTST #1,DSTATUS check flag BNE LSTEP0 MOVE #$2700,SR set priority backup {rdq} BSR RESTORERUN MOVE.L (SP)+,D0 RTS TTL TRAP 15 (BREAK POINT) PAGE * * TRAP15 HANDLER * TRAP15 EQU * MOVE #$2700,SR BLOC CHECK A6 BEQ.S EXECRET MOVE.L #PROCNM,D5 SET COMMAND BRA.S T0PXIT PROCNM DC.B 15,'D "NEXT PROC";?' *======================== * CHKIMPLANT EQU * check for and execute any implants MOVEM.L D0/A0-A1,-(SP) MOVEA.L LASTLINE,A1 lK ISR'S SUBQ.L #2,2(SP) BACKUP PC BSR CLRBRKS CLEANUP BREAK POINTS MOVE.L 2(SP),ACCUMV+2 GET PC MOVE.W #$0104,ACCUMV SET TYPE MOVEM.L A0/D2,-(SP) SAVE WORK REGS BSR FINDACBR FIND BREAK POINT BNE.S T15OPS5 L D6,TRAP0_1 if not then check next task TST.L D5 BNE.S TRAP0_4 IMPLANT DETECTED BCLR #0,DSTATUS2 CHECK 2nd STRING BEQ.S TRAP0_3 MOVE.L TEMPL2,D5 CHANGE 2nd STRING TO 1st BRA.S TRAP0_4 TRAP0_3 MOVEM.L (SP)+,D5-D7/A0-ine address MOVE.W 2(A1),D0 get the line no. MOVEA.L IMFIRST,A0 CHKIM0 CMPI.B #$32,(A0) what type ? BNE.S CHKIM1 CMP.W 4(A0),D0 check the line number/CHG32 BNE.S CHKIM1 LEA 9(A0),A0 CHG32 CMPI.B #$FF,(A0) A1 restore scratch regs BCLR #6,DSTATUS CHECK CALL FLAG BNE DBUGCMD2 CALL INTERPRETER btst #7,(sp) trace bit on? (scs) bne trace trap immediately (scs) rte  COUNT ? BNE.S CHKIM0A TST.L 1(A0) ZERO COUNT SO PERM BP BEQ.S CHKIM3 SUBI.L #1,1(A0) COUNT DOWN BNE.S CHKIM2 LEA NATL,A0 CHKIM0A MOVE.L A0,D5 SET STRING ADDR. BRA.S CHKIM2 NATL DC.B 28,'BC LN;D LN:"NOW return to user (scs) TRAP0_4 MOVE.L D5,TEMPL MOVEM.L (SP)+,D5-D7/A0-A1 restore scratch regs BRA DBUGOBEY * TRAP0JV DC.L QLINE 7 DC.L LFLASH 6 DC.L T0CHKA6 5 DC.L  AT LINE ",;?' CHKIM1 ADDA.L #IMSIZE,A0 next implant CMPA.L IMLAST,A0 done yet ? BNE CHKIM0 CHKIM2 MOVEM.L (SP)+,D0/A0-A1 RTS CHKIM3 LEA NATLP,A0 BRA CHKIM0A NATLP DC.B 24,';D LN:"NOW AT LINE ",;? ' *=================== T0NPROC 4 DC.L RETURN 3 DC.L TSTEPC 2 DC.L LSTEP 1 DC.L CHKIMPLANT 0 *======================== * QLINE EQU * enter LASTLINE into QUEUE MOVE.L A1,-(SP) save scratch reg MOVEA.L ===== * TSTEPC EQU * check and decriment step counter TST.L TCOUNT BNE.S TSTOPC_0 STOPXIT BCLR #2,LTFLAGS kill count check BNE.S TSTOPLT BSET #1,D7 SET STOP FLAG BCLR #2,TFLAGS kill count check RTS TSTOPC_0 SUBQQLAST,A1 MOVE.L LASTLINE,(A1)+ CMPA.L QEND,A1 BNE.S QLINE_1 MOVEA.L QSTART,A1 QLINE_1 MOVE.L A1,QLAST MOVEA.L (SP)+,A1 restore scratch reg RTS * LFLASH EQU * flash the line no. on the CRT MOVE.L D0,-(SP) MOVEQ #6,D0 BSR .L #1,TCOUNT BEQ STOPXIT * FASTXIT ANDI.B #1,D7 ignore remaining ops. RTS except implants TSTOPLT MOVE.L #NATLP,TEMPL2 BSET #0,DSTATUS2 SET 2nd STRING FLAG BRA FASTXIT *========================= LSTEP EQU * wa SYSCALL9 DISPLAY LASTLINE BTST #1,D7 IF STOPPING DON'T WAIT BNE.S LFLASH2 * wait a while MOVE.W #$FFFF,D0 LFLASH1 MOVE.L (SP),(SP) DBRA D0,LFLASH1 LFLASH2 MOVE.L (SP)+,D0 RTS *======================it for step key etc. MOVE.L D0,-(SP) save D0 for use by exchangerun MOVE.B #'s',TEMPR show waiting for step BSR EXCHANGERUN BSET #1,DSTATUS set waiting for stepkey flag MOVE #$2000,SR enable keyboard interupts LSTEP0@     EA 9(A0),A0 CHG32 CMPI.B #$FF,(A0) COUNT BNE.S T15OPS3A TST.L 1(A0) BEQ.S T15OPS6 PERM BP SUBQ.L #1,1(A0) COUNT DOWN BNE.S T15OPS7 LEA NATI,A0 T15OPS3A MOVE.L A0,TEMPL SET ADDRESS MOVEM.L (SP)+,A0/D2 DC.L TSTOP 1 DC.L TDO_TD 0 *================================ * TQLINE MOVEA.L LASTLINE,A1 CMPI.W #$4E40,(A1) BNE QLINE RTS IF TRAP 0 THEN DON'T QUEUE IT * TSTOP MOVE.L #STOPC,D5 TDONE MOVEQ #0,D7 CANCEL TRACE RESTORE WORK REGS BRA DBUGOBEY EXCUTE THE CMD(S) NATI DC.B 30,'BC PC^;D PC:"PC NOW AT ",;TD;?' T15OPS5 LEA UBREAK,A0 BRA T15OPS3A T15OPS6 LEA NATIP,A0 BRA T15OPS3A NATIP DC.B 23,'TD;D PC:"PC NOW AT ",;?' UBREAK DC OPS RTS STOPC DC.B 4,'TD;?' * TDO_TD MOVE.L #DOTD,D5 RTS DOTD DC.B 2,'TD' * * DON'T TRACE EXECPTION VECTORS * TRAPCHK MOVE.L LASTLINE,-(SP) * CLR.B (SP) CLEAR HIGH BYTE CHG32 CMPI.L #$FFFFFEDA,(SP)+ CHG32 * ch.B 26,'D PC:"USER TRAP 15 AT ",;?' * EXECUTE THRU TRAP15 T15OPS7 MOVEM.L (SP)+,A0/D2 RESTORE WORK REGS BSET #7,DSTATUS2 SET THRU BP FLAG BSET #7,(SP) SET TRACE BIT RTE EXECUTE ONE INSTRUCTION TTL TRACE TRAP ROUTINanged 11/28/90 JWH : * BGE TDONE BHI TDONE RTS PAGE * * ERROR TRAP 'EXCEPTION' * * STOP ON ALL EXCEPT UEXCPE BSR.S FINDEC BNE.S UEXCPA RTS * STOP ON ONLY UEXCPO BSR.S FINDEC BEQ.S UEXCPA RTS FINDEC MOVEM.L E PAGE TRACE MOVE #$2700,SR LOCK OUT ISR'S BCLR #7,DSTATUS2 THRU BP ? BEQ.S TRACEA BSR SETBRKS TRACEA BTST #6,DSTATUS2 DEBUGGER TRACE ? BNE.S TRACEC TRACEB BCLR #7,(SP) KILL TRACE BIT RTE BACK TO USERA0/A5/D0/D1,-(SP) (scs) LEA ETCODES,A0 MOVEA.L G_DOLLAR,A5 (scs) MOVE.W escapecode(A5),D1 ESCAPE CODE (scs) MOVEQ #0,D0 MOVE.B NUMET,D0 TRACEC TST.B TFLAGS ANYTHING TO DO ? BNE.S TRACE_0 RTE BACK TO USER * TRACE_0 CMPI.L #REALDEBUGGER,2(SP) BEQ TRACEB DON'T TRACE THRU DEBUGGER CMPI.L #DEBUGESCAPE,2(SP) BEQ TRACEB MOVE.L 2(SP),LASTLINE SAVE PC MOVEM.L  BRA.S FINDEC2 FINDEC1 CMP.W (A0)+,D1 FINDEC2 DBEQ D0,FINDEC1 MOVEM.L (SP)+,A0/A5/D0/D1 (scs) RTS * STOP ON ALL UEXCPA MOVE.L #ECDUMP,TEMPL DUMP EXECPTION UEXCPA1 TST.B M68KTYPE D5-D7/A0-A1,-(SP) save scratch regs MOVEQ #0,D5 CLEAR IMPLANT FLAG MOVEQ #0,D7 clear status reg. MOVE.B TFLAGS,D7 load reg. BSET #6,D7 FORCE TRAP CHK MOVEQ #7,D6 set bit pointer LEA TRACEJV,A0 get jumptable address *  (rdq) BEQ.S UEXCPAA (rdq) MOVE.W (SP),-(SP) MOVE PC DOWN 2 BYTES (rdq) MOVE.W 4(SP),2(SP) (rdq) CLR.W 4(SP) FAKE VECTOR WORD (rdq) UEXCPAA MOVE ETRACE_1 BCLR D6,D7 test & clear the next bit BEQ.S TRACE_2 MOVEA.L (A0),A1 JSR (A1) do the task * TRACE_2 ADDQ.L #4,A0 next jump entry TST.B D7 all done ? DBEQ D6,TRACE_1 if not then check next task MOVE.L D5,TEMPL MXCP_STATUS,-(SP) PUSH SR MOVE #$2700,SR USE MAX PRIORITY BRA DBUGOBEY ECDUMP DC.B 4,'DE;?' DUMP EXCEPTION * STOP AND DO IMPLANT UEXCPIMP MOVE.L UEXCPI,TEMPL BRA UEXCPA1 TTL CRT & KEYBOARD DRIVERS PAGE *----OVEM.L (SP)+,D5-D7/A0-A1 restore scratch regs TST.L TEMPL BNE DBUGOBEY RTE * TRACEJV DC.L TQLINE 7 DC.L TRAPCHK 6 DC.L RETURN 5 DC.L RETURN 4 DC.L RETURN 3 DC.L TSTEPC 2 -------------------------------------------- *------------------------------------------------ * DEBUGGER DRIVERS FOR CRT AND KEYBOARD * rdq MAY 81 -- 24 AUG 81 -- 1 DEC 83 *------------------------------------------------ *------------------------------@     ,D0 UP ARROW BEQ RETURN DINBAD1 BSR.S KBEEP BRA DINPUT1 * KBEEP MOVEQ #6,D0 BRA SYSCALL USE SYSTEM INTERFACE TO BEEP * INKEY EQU * MOVE.B #6,OUTFLAGS BUFFER AND CRT GETKEY BSR READKEYS MOVE.B KBDSTATREG,D1 M * ATGL BTST #5,D1 CNTRL BEQ.S CRTSWAP BTST #4,D1 SHIFT (DUMP ALPHA) BEQ DODUMPA * ATGL1 BTST #0,AONOFF TEST ALPHA BNE.S ATGL2 BSR.S ALONOFF TURN ON ALPHA BRA GETKEY ATGL2 BTST #0,GONOFF TEST GOVE.B KBDCHAR,D0 TST.B KBDTRANSCODE 0=ALPHA 1=SPECIAL BNE.S KUDKSVC SPECIAL * DROP THRU FOR ALPHA * ----------------------------------------------- KPRNT0 EQU * HAVE ALPHA TEXT BSR OUTBYTE OUTPUT ONE RAPHICS BEQ GETKEY BSR.S GRONOFF TURN OFF GRAPHICS BRA GETKEY * ALONOFF MOVEQ #8,D0 TOGGLE ALPHA CALL BRA SYSCALL * CRTSWAP EQU * BTST #4,DSTATUS CRT STATUS BEQ.S MAKEDCRT BSR UNSAVECRT BRA GE------------------ * * EQUATES FOR KEYBOARD & CRT DRIVERS * TRAP10V EQU $FFFFFF58 * PROMPT MOVE.B #4,OUTFLAGS CRT BTST #6,DSTATUS2 CHECK TRACE MODE BEQ.S PROMPT0 MOVEQ #'T',D0 TRACE MODE PROMPT BSR OUTBYTE PROMPT0 MOVEQ #'>'CHARACTER BCLR #7,DSTATUS CLEAR ERROR FLAG BRA GETKEY KINTRT RTS * FUNCTAB EQU * DC.W KINTRT-FUNCTAB CAPS LOCK (KEYCODE 24) DC.W KINTRT-FUNCTAB TAB DC.W UDK0-FUNCTAB K0 DC.W UDK1-FUNCTAB K1 DC.W UDK2-FUNCTAB ,D0 PROMPT ">" BRA OUTBYTE * * IF DONE FLAG IS SET THEN CURRENT COMMAND * IS FROM BREAK POINT. INPUT CANCELS THE * AUTO RETURN TO USER CODE * PDINPUT BSET #2,DSTATUS2 WANT UP/DOWN DINPUT EQU * BCLR #5,DSTATUS CLEAR DONE FLAG BSR K2 DC.W UDK5-FUNCTAB K5 DC.W UDK6-FUNCTAB K6 DC.W UDK7-FUNCTAB K7 DC.W UDK3-FUNCTAB K3 DC.W UDK4-FUNCTAB K4 DC.W UPDOWN-FUNCTAB DOWN ARROW DC.W UPDOWN-FUNCTAB UP ARROW DC.W UDK8-FUNCTAB K8 DC.W UDK9 INPUTCLR CLEAR INPUT BUFFER LEA DINBUF,A4 BUFFER ADDRESS MOVE.W #DINBUFMAX,D7 BUFFER SIZE MOVEQ #0,D6 CURRENT SIZE MOVE.W D6,D5 CURRENT POSITION BSR PROMPT DINPUT1 BSR.S INKEY MOVE.B #4,OUTFLAGS CRT ONLY TS-FUNCTAB K9 DC.W LEFT-FUNCTAB LEFT ARROW DC.W RIGHT-FUNCTAB RIGHT ARROW DC.W KINTRT-FUNCTAB INS LN DC.W GTGL-FUNCTAB DEL LN ANOTHER WORT FOR THE 9816A KEYBOARD DC.W RECALL-FUNCTAB RECALL DC.W INSERT-FUNCTAB INS CHR DT D1 BNE.S DINBAD BCLR #2,DSTATUS2 NOT UP/DOWN ARROW MOVE.B D6,DINSIZE BEQ.S DINPUT1C CHECK NO INPUT * COPY TO RECALL BUFFER MOVEA.L RECALLV,A0 POINT A0 TO RECALL BUF. MOVE.W D6,(A0)+ SET LENGC.W DELETE-FUNCTAB DEL CHR DC.W CLREND-FUNCTAB CLR END DC.W BACKSP-FUNCTAB BACK SPACE DC.W KINTRT-FUNCTAB RUN DC.W KINTRT-FUNCTAB EDIT DC.W ATGL-FUNCTAB ALPHA DC.W GTGL-FUNCTAB GRAPHICS DC.W STEPKEY-FUNCTAB STEP DTH JS 4/29/85 MOVEA.L A4,A1 FROM INPUT BUF. MOVE.W D6,D1 BRA.S DINPUT1B DINPUT1A MOVE.B (A1)+,(A0)+ DINPUT1B DBRA D1,DINPUT1A * DINPUTX LEA DINSIZE,A0 RETURN RTS * DINPUT1C BTST #6,DSTATUS2 TRACE MODE ? BEQ DINPUTX MOVE.C.W CLEARLN-FUNCTAB CLR LN/CLR SCR DC.W KINTRT-FUNCTAB RESULT DC.W KINTRT-FUNCTAB PRT ALL DC.W STOPKEY-FUNCTAB STOP DC.W PAUSEKEY-FUNCTAB PAUSE DC.W EXECKEY-FUNCTAB ENTER DC.W CONKEY-FUNCTAB CONTINUE DC.W EXECKEY1-FUNCTAB B #1,DINSIZE DEFAULT T COMMAND MOVE.B #'T',DINBUF BRA DINPUTX RETURN * DINBAD BTST #2,DSTATUS2 ALLOW UP/DOWN ? BEQ.S DINBAD1 BCLR #3,DSTATUS2 CMPI.B #$22,D0 DOWN ARROW BEQ RETURN BSET #3,DSTATUS2 CMPI.B #$23EXECUTE * KUDKSVC EQU * SPECIAL KEY SERVICE MOVEQ #0,D2 MOVE.B KBDCHAR,D2 CMPI.B #$18,D2 BCS KINTRT CAN'T HANDLE IT SUB.B #$18,D2 LSL.B #1,D2 LEA FUNCTAB,A0 ADDA.W 0(A0,D2),A0 JMP (A0) * * HANDLE ALPHA KEYS (CRTL / SHIFT)A     TKEY MAKEDCRT BSR SAVECRT BRA GETKEY * * GRAPHICS KEY (SHIFT / CNTRL) * GTGL BTST #5,D1 CNTRL BEQ KINTRT CAN'T HANDLE CTRL GRAPHICS BTST #4,D1 SHIFT (DUMP GRAPHICS) BEQ DODUMPG * BEQ KINTRT CAN'T RINT THE PROMPTSTRING READAGAIN EQU * BSR READKEYS EXEC/ENTER TO CONTINUE * SHIFT EXEC TO STOP MOVE.B KBDSTATREG,D1 ANDI.B #$F0,D1 CHECK SHIFT/CTRL BITS CMPI.B #$B0,D1 NORMAL ? BEQ.S IFEXEC CMPI.B #$A0,D1 SHIFT ? BHANDLE IT BTST #0,GONOFF TEST GRAPHICS BNE.S GTGL1 BSR.S GRONOFF TURN ON GRAPHICS BRA GETKEY GTGL1 BTST #0,AONOFF TEST ALPHA BEQ GETKEY BSR ALONOFF TURN OFF ALPHA BRA GETKEY * GRONOFF MOVEQ #NE READAGAIN CMPI.B #$3B,D0 SHIFT EXEC ? BNE READAGAIN MOVEA.W LINECOUNT,A0 NO MESSAGE ESCAPE BRA ESCAPE IFEXEC MOVE.B KBDCHAR,D0 CMPI.B #$3B,D0 EXEC ? BEQ.S READRET CMPI.B #$39,D0 ENTER ? BNE.S READAGAIN READRET MOVEM.L (SP)+,1,D0 TOGGLE GRAPHICS CALL BRA SYSCALL * BLANKDCRT EQU * BLANK DEBUGGER "CRT" MOVE.L D0,-(SP) BTST #4,DSTATUS BEQ.S DCRTM MOVEQ #5,D0 "CRT" IS SCREEN BRA.S DCRTM0 * DCRTM MOVEQ #4,D0 "CRT" IS RAM DCRTM0 BSR SYSCALLD0-D2/A0 RTS * MORE CRT INTERFACE OUTEOL MOVE.B #3,-(SP) JCALL0 MOVE.B (SP)+,CRTOPCODE { MUST ALLWAYS JUMP HERE } MOVE.L D0,-(SP) { SAVE THEN RESTORE D0 } MOVEQ #0,D0 BSR SYSCALL MOVE.L (SP)+,D0 RETX RTS CBWD MOVE.B #8,0 MOVE.L (SP)+,D0 RTS * * OUTPUT A BYTE TO CRT/BUFFER OUTBYTE EQU * BTST #7,DSTATUS IF ERROR BNE.S OUTXIT DON'T DO ANYTHING BTST #1,OUTFLAGS BUFFER BEQ.S OUTBYTE1 BSR.S BUFOUT BTST #7,DSTATUS BNE.S OUTXIT OUTB-(SP) { BACKUP THE CURSOR } BRA JCALL0 CFWD MOVE.B #9,-(SP) { CURSOR FORWARD } BRA JCALL0 * CONKEY BSR CLRBUF KILL ANY INPUT BSR.S CLRFLASH CLEAR FLASH DISPLAY ANDI.B #$B9,LTFLAGS KILL STEP,FLASH,AND COUNT RYTE1 BTST #2,OUTFLAGS CRT BNE.S CRTOUT OUTXIT RTS * PUT A CHARACTER IN THE BUFFER BUFOUT CMP.W D7,D5 BEQ.S BUFERR ALREADY AT END MOVE.B D0,0(A4,D5) PUT IN BUFFER CMP.W D5,D6 BNE.S BUFOUT1 ADDQ.W #1,D6 NEW SIZE BUUNEXIT BCLR #6,DSTATUS2 KILL TRACE MODE BSET #5,DSTATUS SET DONE FLAG EXECKEY BSR OUTEOL ENDKEY MOVEQ #0,D1 NORMAL EOL RTS EXECKEY1 BTST #5,D1 THIS IS A WORT FOR THE 9816A KEYBOARD BEQ CRTSWAP BRA EXECKEY * CLRFLASHFOUT1 ADDQ.W #1,D5 BUFXIT RTS BUFERR BSET #7,DSTATUS BUFFER OVERFLOW BRA KBEEP * * SEND ONE CHARACTER TO CRT * CRTOUT BSR SAVECRT FORCE DEBUGGER CRT CRTOUT1 MOVE.B D0,CRTCHAR MOVEQ #1,D0 PUT CHAR & ADVANCE CURSOR BSR SY MOVEQ #4,D0 CLEAR FLASH DISPLAY BRA SYSCALL9 (SYSCALL9 DOES RTS) * UDK0 LEA K0DATA,A0 GET INFO VECTOR BRA.S DOUDK UDK1 LEA K1DATA,A0 BRA.S DOUDK UDK2 LEA K2DATA,A0 BRA.S DOUDK UDK3 LEA K3DASCALL0 BTST #0,OUTFLAGS CHECK COUNTER ? BEQ.S CRTRET CMPI.W #21,LINECOUNT BEQ.S WAITPROMPT CRTRET RTS * TOO MUCH DATA FOR ONE SCREEN SO WAIT * FOR OPERATOR TO CONTINUE OR CANCEL. * IF EXECUTING BREAK POINT IMPLANT (DONE FLAG * SET) THETA,A0 BRA.S DOUDK UDK4 LEA K4DATA,A0 BRA.S DOUDK UDK5 LEA K5DATA,A0 BRA.S DOUDK UDK6 LEA K6DATA,A0 BRA.S DOUDK UDK7 LEA K7DATA,A0 BRA.S DOUDK UDK8 LEA K8DATA,A0 BRA.S DOUDK UDK9 LEA K9DATA,A0 DOUDN CANCEL AUTO RETURN TO USER CODE * WAITPROMPT EQU * BCLR #5,DSTATUS CLEAR DONE FLAG MOVEM.L D0-D2/A0,-(SP) CLR.W LINECOUNT RESET THE COUNTER MOVE.L #'MORE',CRTPROMPT MOVE.B #4,CRTPROMPTSIZE MOVEQ #2,D0 BSR SYSCALL0 PK ANDI.B #$30,D1 NO SHIFT OR CTRL CMPI.B #$30,D1 BNE.S BEEPEND BSR OUTINFO BCLR #7,DSTATUS CLEAR ERROR FLAG BRA GETKEY * * UP/DOWN ARROW KEYS UPDOWN ANDI.B #$30,D1 NO CTRL OR SHIFT CMPI.B #$30,D1 RTS * BEEPEND BSR A     YS (scs) JMP TRAP10V JUMP TO TRAP #10 VECTOR * STEPKEY BTST #4,D1 SHIFT BEQ BEEPEND BSR CLRBUF KILL INPUT BUFFER BTST #5,D1 CRTL BEQ.S SFLASH ORI.B #$42,LTFLAGS SET FLASH & STEP BCLR #2,LTFLAGS CLED AT END CMP.W D6,D7 BEQ BEEPEND NO ROOM MOVE.W D5,D4 SAVE CURSOR MOVEQ #' ',D0 INS1 MOVE.B 0(A4,D5),D1 BSR OUTBYTE MOVE.B D1,D0 SHIFT CHARACTER CMP.W D5,D6 BNE INS1 BSR OUTBYTE PUT LAST ONE INS2 BSR CBWD AR COUNT MOVEQ #'s',D0 BSR SHOWSTAT0 BRA RUNEXIT * SFLASH BSET #6,LTFLAGS SET FLASH FLAG ANDI.B #$F9,LTFLAGS CLEAR STEP & COUNT MOVEQ #'f',D0 BSR SHOWSTAT0 BRA RUNEXIT * LEFT TST.W D5 LEFT CURSOR BEQ BRE POSITION CURSOR SUBQ.W #1,D5 CMP.W D5,D4 BNE INS2 BRA GETKEY * DELETE CHARACTER DELETE CMP.W D5,D6 BEQ BEEPEND AT END MOVE.W D5,D4 SAVE D5 (CURSOR) DEL1 MOVE.B 1(A4,D5),D0 BSR OUTBYTE CMP.W D5,D6 BNEKBEEP BRA GETKEY * PAUSE KEY OPS {rdq} PAUSEKEY MOVE.B REGSR,D1 ANDI.B #$0F,D1 DISALLOW PAUSE IF BNE BEEPEND PRIORITY NON ZERO BSR CLRBUF MOVE.L REGPC,PCTEMP SAVE PC AND SR MOVEEEPEND AT END ALREADY BTST #5,D1 CTRL ? BEQ BEEPEND BTST #4,D1 SHIFT (TO BOL) BNE.S LEFT1 BSR.S MOVBOL RETURN TO BOL BRA GETKEY LEFT1 BSR CBWD BACKUP CURSOR SUBQ.W #1,D5 BRA GETKEY * MOVBOL TST.W D5 CURS.W REGSR,SRTEMP MOVE.L #WAITSET,REGPC SET TO GAIN MOVE.W #$2700,REGSR CONTROL AS USER BRA RUNEXIT WAITSET MOVE.L D0,-(SP) SWITCH RUNLIGHT THEN GOTO WAITContinue MOVE.B #'p',TEMPR BSR EXCHANGERUN MOVE.L (SP)+,D0 BSET #1,DOR AND POINTER TO BOL BEQ RETX BSR CBWD SUBQ.W #1,D5 BRA MOVBOL * MOVEOL CMP.W D5,D6 CURSOR AND POINTER TO EOL BEQ RETX BSR CFWD ADDQ.W #1,D5 BRA MOVEOL * RIGHT CMP.W D5,D6 RIGHT CURSOR BEQ BEEPEND AT END ASTATUS SET WAITING FLAG BRA WAITC * STOP AND CLR I/O STOPKEY MOVE.B REGSR,D1 CHECK PRIORITY BTST #5,D1 IF USER MODE THEN OK {RQ} BEQ.S STOPK1 ANDI.B #$0F,D1 DISALLOW STOP IF BNE BEEPEND PRIORITY NON ZERO STOPK1 LREADY BTST #5,D1 CTRL ? BEQ BEEPEND BTST #4,D1 SHIFT (TO EOL) BNE.S RIGHT1 BSR MOVEOL ADVANCE TO EOL BRA GETKEY RIGHT1 BSR CFWD ADVANCE CURSOR ADDQ.W #1,D5 BRA GETKEY * CLEARLN BTST #5,D1 CTRL ? BEQ BSR CLRBUF MOVE.W #RTSOP,SAVEESC KILL ET TRAPS MOVE.L REGPC,PCTEMP SAVE PC AND SR MOVE.W REGSR,SRTEMP MOVE.L #FAKESTOP,REGPC SET TO GAIN MOVE.W #$2700,REGSR CONTROL THE RETURN BRA RUNEXIT * FAKESTOP TST.B M68KTYPE GENERATEBEEPEND BSR.S CLRBUF BTST #4,D1 SHIFT (CLR SCR) BNE GETKEY BSR BLANKDCRT CLEAR DEBUG CRT BSR PROMPT REPLACE PROMPT BRA INKEY SET OUTFLAGS THEN GETKEY * DELLN BSR.S CLRBUF CLEAR THE LINE BRA GETKEY * CLRXIT R EXCEPTION INFO (rdq) BEQ.S FS1 (rdq) MOVE.W #$A8,-(SP) FAKE VECTOR WORD (rdq) FS1 MOVE.L PCTEMP,-(SP) move initsr,-(sp) TS CLRBUF TST.W D6 BEQ.S CLRXIT BSR MOVBOL CALLCLREND MOVE.W D5,D6 SET SIZE MOVE.B #6,-(SP) CLEAR LINE TO END OF LINE BRA JCALL0 (XCALL0 DOES RTS) * RECALL BTST #4,D1 SHIFT BEQ ATGL1 ALPHA KEY WORT FOR THE 981 (scs) move #$2000,sr (scs) MOVEA.L G_DOLLAR,A5 GENERATE ESC -20 MOVE.W #-20,escapecode(A5) ESC CODE (scs) MOVE.L INITRECOVER,recoverblk(A5) RECOVER TO S6A KEYBOARD BSR CLRBUF MOVEA.L RECALLV,A0 MOVEQ #0,D1 MOVE.W (A0)+,D1 PICK UP LENGTH JS 4/29/85 BRA.S RECALL_B RECALL_A MOVE.B (A0)+,D0 BSR OUTBYTE RECALL_B DBRA D1,RECALL_A BRA GETKEY * INSERT CMP.W D5,D6 BEQ BEEPENB      DEL1 BSR.S DOBAKSP BLANK LAST CHR DEL2 CMP.W D5,D4 RE POSITION CURSOR BEQ GETKEY BSR CBWD SUBQ.W #1,D5 BRA DEL2 * CLREND CMP.W D5,D6 CLEAR TO END OF LINE BEQ BEEPEND AT END BSR CALLCLREND BRA GETKEY * BACULT_ADDR EQU HIGHMEM { PARITY ERROR } * 68000 BE_SSW EQU HIGHMEM SPECIAL STATUS WORD BE_FAULT_ADDR EQU BE_SSW+2 FAULT ADDRESS BE_INSTR EQU BE_FAULT_ADDR+4 IKSP BSR.S DOBAKSP BRA GETKEY DOBAKSP TST.W D5 BEQ.S DBAKXIT BSR CBWD BACK ONE SUBQ.W #1,D5 MOVEQ #' ',D0 BLANK BSR OUTBYTE BSR CBWD BACK AGAIN CMP.W D5,D6 BNE.S DBAK1 SUBQ.W #1,D6 DBAK1 SUBQ.W #1,D5 DBAKXITNSTRUCTION BUFFER * * 68010 *BE_SSW 2 BYTES VECTOR TYPE 1000 *BE_FAULT_ADDR 4 BYTES BE_PAD1_10 EQU BE_FAULT_ADDR+4 BE_DATAO_10 EQU BE_PAD1_10+2 DATA INPUT BUFFER BE_PAD2_10  RTS PAGE * READKEYS EQU * MOVEQ #7,D0 CALL SYSTEM INTERFACE BRA.S SYSCALL TO READ & TRANSLATE A KEY * SYSCALL0 EQU * CRT INTERFACE CALLS MOVE.B D0,CRTOPCODE MOVEQ #0,D0 BRA.S SYSCALL * RESTORERUN MOVEQ #1,D0 BRA.S SYSCALL9  EQU BE_DATAO_10+2 BE_DATAI_10 EQU BE_PAD2_10+2 DATA OUTPUT BUFFER BE_PAD3_10 EQU BE_DATAI_10+2 BE_INSTR_10 EQU BE_PAD3_10+2 INSTRUCTION BUFFER BE_MISC_10 EQU BE_INSTR_10+2 16 WORDS BE_END_10 EQU EXCHANGERUN MOVEQ #0,D0 SYSCALL9 MOVE.B D0,LASTLINEOP MOVEQ #9,D0 * CALL SYSTEM RESIDENT PROCEDURES SYSCALL MOVEM.L A0-A6/D1-D7,-(SP) MOVEA.L G_DOLLAR,A5 SET GLOBALBASE MOVE.W IORESULT(A5),-(SP) SAVE AND RESTORE MOVE.W ESCAPECODE(A5)BE_MISC_10+32 * * 68020 ERR_PC EQU HIGHMEM VECTOR TYPE 0010 *ERR_PC 4 BYTES VECTOR TYPE 1001 ERR_WRD1 EQU ERR_PC+4 ERR_WRD2 EQU ERR_WRD1+2 ERR_EA ,-(SP) IORESULT AND ESCAPE CODE MOVE.L D0,-(SP) PUSH THE ARGUMENT JSR SYSBUG_CALLSYSCODE MOVE.W (SP)+,ESCAPECODE(A5) MOVE.W (SP)+,IORESULT(A5) MOVEM.L (SP)+,A0-A6/D1-D7 RTS DODUMPA MOVEQ #2,D0 BRA.S DODUMP0 DODUMPG MOVEQ #3,D EQU ERR_WRD2+2 EVALUATED ADDRESS *BE_SSW 4 BYTES VECTOR TYPE 1010 (SHORT BUS ERROR) BE_IPSC EQU BE_SSW+4 I PIPE C BE_IPSB EQU BE_IPSC+2 I PIPE B BE_PAD2_20 EQU BE_IPSB+2 BE_0 DODUMP0 BTST #5,REGSR ALLOW ONLY IF USER MODE BNE BEEPEND BSR SYSCALL BRA GETKEY * TTL DEBUGGER/SYSTEM COMMON PAGE *------------------------------------------------ *------------------------------------------------ * DEBUGGFAULT_ADDR20 EQU BE_PAD2_20+4 BE_DATA_20 EQU BE_FAULT_ADDR20+4 DATA BUFFER BE_MISCS_20 EQU BE_DATA_20+4 4 BYTES BE_END_S_20 EQU BE_MISCS_20+4 * *BE_SSW 4 BYTES VECTOR TYPE 1011 (LONG BUS ERROR) *BER COMMON DECLARATIONS * rdq MAY 81 *------------------------------------------------ *------------------------------------------------ * TRAP0V EQU $FFFFFF94 TRAP15V EQU $FFFFFF3A TRACEV EQU $FFFFFFD0 HIGHMEM EQU $FFFFFB00 START ALE_IPSC 2 BYTES *BE_IPSB 2 BYTES *BE_PAD 4 BYTES *BE_FAULT_ADDR 4 BYTES *BE_DATAO 4 BYTES BE_PAD3_20 EQU BE_DATA_20+4 16 BYTES BE_DATAI_20 EQU BE_PAD3_20+16 BE_MISC20_20 EQU BE_DATAI_20+4 LOCATION OF FIXED DATA AREA * SEE ALSO INITBUG, POWERUP AND ASM WHEN CHANGES ARE MADE * TO THE FOLLOWING DATA STRUCTURE *------------------------------------------------ * * THE FOLLOWING DATA MAY COVER THE BOOTER STACK * ERR_INFO EQU HIGHMEM FA 40 BYTES BE_END_L_20 EQU BE_MISC20_20+44 BE_END EQU BE_END_L_20 *----------------------------------------------------------------------------- EXCP_STATUS EQU BE_END EXCP_PC EQU EXCP_STATUS+2 EXCP_VOFFSET EQB     DSTATUS2 DS.B 1 DEBUGGER CONTROL FLAGS * * LTFLAGS BIT INTERPRETATION * 0 ACTIVE IMPLANTS * 1 WAIT FOR (step,ctrl step,continue) * 2 CHECK & DECRIMER OLDA6 DS.B 4 OLD A6 FOR PCMD SFA6 DS.B 4 A6 FOR WCMD IMFIRST DS.B 4 IMPLANT TABLE START IMLAST DS.B 4 IMPLANT TABLE END IMSIZE EQU 90 CHG32 * FLAGSENT THE COUNT * 3 NO_OP * 4 CHECK A6 (PNEXT COMMAND) * 5 CHECK A6 (P COMMAND) * 6 FLASH THE LINE NUMBER * 7 QUEUE TH DS.W 1 STATUS BITS CHG32 * ADDR DS.L 1 ADDRESS/LINE NUMBER * UCODE DS.W 1 STORAGE FOR USER CODE WORD * DS.B 1 MAX SIZE OF STRING (80) * DS.B 1 $FF U EXCP_PC+4 VECTOR WORD FOR 680xx EXCP_LINE EQU EXCP_VOFFSET+2 EXCEPTION LINE # LASTLINE EQU EXCP_LINE+4 * LASTLINE IS POINTER TO LAST LINE # OR PC ESCAPEV EQU LASTLINE+4 VECTOR TO COMME LINE NUMBER * * TFLAGS BIT INTERPRETATION * 0 TD CONTINUE * 1 TD & STOP * 2 CHECK & DECRIMENT THE COUNT * 3 NO_OP * ON ESCAPE HANDLER PCTEMP EQU ESCAPEV+6 SRTEMP EQU PCTEMP+4 INITSTACK EQU SRTEMP+2 INITIAL USER SP INITPC EQU INITSTACK+4 INITIAL USER PC INITRECOVER EQU INITPC+4 SYSTEM RECOVER G_DO 4 NO_OP * 5 NO_OP * 6 TRAP CHECK * 7 QUEUE THE PC * * DSTATUS BIT INTERPRETATION * 0 USER REGISTERS SAVED *LLAR EQU INITRECOVER+4 SYSTEM GLOBALS CTL_RESETV EQU G_DOLLAR+4 CTL SHIFT PAUSE VECTOR DEBUGESCAPE EQU CTL_RESETV+6 SYS ESCAPE HOOK BESPTEMP EQU DEBUGESCAPE+6 USED IN IGNOREBUS AONOFF EQU BESP 1 WAITING FOR CONTINUE TYPE COMMAND * 2 GO/BR COMMAND * 3 RECOVERY IN PLACE FLAG * 4 USER CRT SAVED * 5 DONE FLAG *TEMP+4 ALPHA ON OFF GONOFF EQU AONOFF+1 GRAPHICS ON OFF GRAPHICSBASE EQU GONOFF+1 GRAPHICS BASE ADDRESS (rdq) INITSR EQU GRAPHICSBASE+4 STATUS REGISTER FOR STOP M68KTYPE EQU INITSR+2 6 CALL DEBUGGER FROM WAIT STATE * 7 ERROR FLAG * * DSTATUS2 BIT INTERPRETATION * 0 DBUGOBEY TEMPL2 ALSO HAS COMMAND * 1 DEBUGGE PROCESSOR TYPE 0=68000 else 680xx MSYSFLAGS EQU M68KTYPE+1 MORE SYSTEM FLAGS bit0 = CACHE FLTPTHWD EQU MSYSFLAGS+1 FLOAT CARD PRESENT FILLER EQU FLTPTHWD+1 TTL DEBUGGER GLOBAL SPACE PAGE ORG R RUNNING * 2 HAVE UP/DOWN ARROW * 3 1=UP, 0=DOWN * 4 RESET INTERUPT OCCURED * 5 DO / DON'T EXECUTE CURRENT COMMAND * 6 FILLER+1 * SAVEBUS DS.B 6 SAVE BUS ERROR FOR DEBUGGER SAVEESC DS.B 6 SAVE DEBUG ESCAPE VECTOR * LTFLAGS DS.B 1 TRACE (TRAP0) FLAGS TFLAGS DS.B 1 TRACE (TRACE VECTOR) FLAGS DSTATUS DS.B 1 DEBUGGER CONTROL FLAGS  TRACE MODE FLAG * 7 EXECUTE THRU TRAP 15 * PAGE QSTART DS.B 4 POINTER TO Q START QEND DS.B 4 POINTER TO Q END QLAST DS.B 4 POINTER TO NEXT ENTRY IN QUEUE TCOUNT DS.B 4 TRACE COUNTC     FOR BREAK COUNT * STRING LENGTH FOR IMPLANTED COMMAND KDATAP DS.B 4 POINTER TO K0..K9 DATA AREA K0DATA DS.B 6 TYPE DS.B SIZE DS.B VALUE DS.L K1DATA DS.B 6 K2DATA DS.B 6 K3DATA  DS.B 4 FORMAT SIZE RCOUNT DS.B 4 FORMAT REPEAT COUNT ETCODES DS.B 8 ESCAPE CODE LIST NUMET DS.B 1 No. OF ESCAPE CODES SCODE DS.B 1 FORMAT CODE DSCODE DS.B 1 DEFAULT FORMAT CODE TEMPD DS.B 1 DS.B 6 K4DATA DS.B 6 K5DATA DS.B 6 K6DATA DS.B 6 K7DATA DS.B 6 K8DATA DS.B 6 K9DATA DS.B 6 * REGPC DS.B 4 user register storage during command xqt REGSR DS.B 2 STATUS REGISTER RE TEMP FOR DEBUGGER COMMAND RUNLIGHT TEMPR DS.B 1 TEMP FOR DEBUGGER/TRAP0 RUNLIGHT OUTFLAGS DS.B 1 * BIT INTERPRETATION * 0 CHECK LINE COUNTER * 1 OUTPUT TO BUFFER * GUS DS.B 4 USER MODE STACK POINTER REGS EQU * DREGS DS.B 32 REGISTERS D0 .. D7 AREGS DS.B 28 REGISTERS A0 .. A6 REGA7 DS.B 4 * CRTOPCODE DS.B 1 CRT OPCODE FOR SYSCALL0 * 02 OUTPUT TO CRT * LINECOUNT DS.W 1 LINECOUNTER FOR DUMPING RECALLV DS.B 4 RECALL VECTOR TEMPL EQU RECALLV+4 SCRATCH WORDS TEMPL2 EQU TEMPL+4 TEMPL3 EQU TEMPL2+4 TEMPL4 EQU TEM=EXCHANGE CRT 6=CLEAR LINE & HOME ON LINE * 1=PUTCHAR & ADVANCE CURSOR * 2=WRITE CRTPROMPT 7=CURSOR TO LINE START * 3=DO CR LF 8=BACKUP CURSOR * PL3+4 SAVEHOOK EQU TEMPL4+4 SAVED ESCAPEHOOK FOR RESET (rdq) INSTACK EQU SAVEHOOK+6 INPUT STACK (rdq) INSTACKB EQU INSTACK+4 JWS 6/12/85 INSTACKE EQU INSTACKB+4 JW 4=INIT(CLEAR) RAM 9=ADVANCE CURSOR * 5=CLEAR CRT & HOME CURSOR CRTCHAR DS.B 1 CRTPADDING1 DS.B 1 UN USED CRTPROMPTSIZE DS.B 1 CRTPROMPT DS.B 4 CRT PROMPT CHARS CRTPADDING2 DS.B 4 UN USED LASTLINEOS 6/12/85 INFILLER EQU INSTACKE+4 JWS 6/12/85 OPSTACK EQU INFILLER+4 JWS 6/12/85 PARSER STACK OPSTACKE EQU OPSTACK+48 DINBUFMAX EQU 80 RECALLMAX EQU DINBUFMAX+2 ADDED WORD FOR LENGTH P DS.B 1 0=EXG RUNLIGHT&TEMPR * 1=TEMPR->RUNLIGHT * 2='d'->RUNLIGHT * 3=CLEAR FLASH & TEMPD->RUNLIGHT * 4=CLEAR FLASH * 5=SHOW STAT0CHAR *  JS 4/29/85 UDKSIZE EQU DINBUFMAX DINSIZE EQU OPSTACKE CURRENT SIZE OF INPUT BUFFER DINBUF EQU DINSIZE+1 INPUT BUFFER (80 BYTES) * SAVE HOOK MUST BE ON AN EVEN ADDRESS  6=DISPLAY LASTLINE STAT0CHAR DS.B 1 CRTPADDING3 DS.B 2 UN USED * KBDSTATREG DS.B 1 KEYBOARD STATUS REG KBDCHAR DS.B 1 DATA REG/ASCII CHARACTER KBDDUMMY DS.B 1 UN USED KBDTRANSCODE DS.B 1 TRANSLATIOHIBUGRAM EQU DINBUF+DINBUFMAX * REGA6 EQU REGA7-4 REGA5 EQU REGA6-4 * DATAT EQU DATAV 0=EMPTY,1=ADDRESS,2=DECIMAL,3=ALPHA,4=HEX etc DATAS EQU DATAV+1 DATAD EQU DATAV+2 * ACCUMT EQU ACCUMV ACCUMS EQU ACCUN CODE 0=ASCII 1=SPECIAL * UEXCPI DS.B 4 ADDRESS OF ERROR TRAP IMPLANT SYMBOLHOOK DS.B 6 SYMBOLTABLE HOOK ACCUMV DS.B 6 ACCUMULATOR DATAV DS.B 6 DATA VALUE BASE DS.B 2 INPUT NUMBER BASE 16 10 8 2 SSIZE MV+1 ACCUMD EQU ACCUMV+2 * END C     O NOT CHANGE THIS RECORD WITHOUT CHANGEING THE DEBUGGER ASSEMBLY CODE **} {** SEE ALSO MODULE POWERUP **} {****************************************************************************} { ERROR RECORDS } TYPE; FILLER : BYTE; SAVEBUS : JVECTOR; SAVEESC : JVECTOR; CTRL_FLAGS : PACKED ARRAY[1..4] OF CHAR; QSTART : INTEGER; QEND : INTEGER; QLAST : INTEGER; TCOUNT : INTEGER; OLDA6 : 20 = PACKED RECORD CASE INTEGER OF 0010:(ERR_PC : INTEGER); 1001:(ERR_PC1: INTEGER; ERR_WRDS:INTEGER; ERR_EA : INTEGER); 1010:(BE_SSW_10 : INTEGER; {SHORT BUS ERROR} BE_IPSC_10: DWORD; BE_IPSB_10: DWORD; BE_PINTEGER; SFA6 : INTEGER; IMFIRST : INTEGER; IMLAST : INTEGER; KDATAP : INTEGER; { K0..K9 DATA AREA POINTER } KVECTOR : ARRAY[0..9] OF KRECORD; REGPC : INTEGER; REGSR : DWORD; REGUS  (* (c) Copyright Hewlett-Packard Company, 1985. All rights are reserved. Copying or other reproduction of this program except for archival purposes is prohibited without the prior written consent of Hewlett-Packard Company. RESTRICTEDAD_10 : INTEGER; BE_FAULT_10:INTEGER; {FAULT ADDRESS} BE_DATA_10: INTEGER; { DATA IN/OUT } BE_PAD2_10: INTEGER); 1011:(BE_SSW_11 : INTEGER;{LONG BUS ERROR} BE_IPSC_11: DWORD; BE_IPSB_11: DWORD; BE_PAD_11 : INTEGER; BE_F RIGHTS LEGEND Use, duplication, or disclosure by the Government is subject to restrictions as set forth in paragraph (b) (3) (B) of the Rights in Technical Data and Computer Software clause in DAR 7-104.9(a). HEWLETT-PACKARD COMPANY Fort Collins, ColoraAULT_11:INTEGER; {FAULT ADDRESS} BE_DATAOUT: INTEGER; BE_PAD6 : PACKED ARRAY[1..16] OF CHAR; BE_DATAI_11 : INTEGER; BE_MISC20 : PACKED ARRAY[1..44] OF CHAR) END; ERRORINFOREC = PACKED RECORD CASE INTEGER OF 68000:(BE_SSdo *) $SYSPROG$ $RANGE OFF, STACKCHECK OFF, OVFLCHECK OFF$ $DEBUG OFF$ $ALLOW_PACKED ON$ program installdebugger; $COPYRIGHT '(C) 1985 HEWLETT-PACKARD CO. 3.0'$ module sysbug; { this module is used by the debugger when it needs W_00 : DWORD; BE_FAULT_ADDR : INTEGER; BE_INSTR : DWORD); 68010:(BE_SSW_10 : DWORD; BE_FAULT_ADDR10:INTEGER; BE_PAD1_10 : DWORD; BE_DATAO_10 : DWORD; BE_PAD2_10 : DWORD; BE_DATAI_10 : DWORD;  to call system resident code } IMPORT SYSGLOBALS, LOADER, SYSDEVS, ASM; export procedure callsyscode(i : integer); implement type menu1 = array[boolean] of menutype; menu2 = array[m_none..m_sysshift] of menu1; const mstates = menu2[ {  BE_PAD3_10 : DWORD; BE_INSTR_10 : DWORD; BE_MISC_10 : PACKED ARRAY[1..32] OF CHAR); 68020:(M68020:TYPE20) END; DEBUGCOMTYPE = PACKED RECORD ERRINFO : ERRORINFOREC; EXCP_STATUS : DWORD; EXCP_PC : INTEGER; EXno menu } menu1[m_sysnorm,m_sysshift], { normal } menu1[m_none,m_sysshift], { shifted } menu1[m_sysnorm,m_none]]; inmaxsize = 80; imsize = 88; type realp = ^real; str80p= ^string80; dword = 0..65535; jvector = packed arrayCP_VOFFSET : DWORD; EXCP_LINE : INTEGER; LASTLINE : ^LLREC; ESCAPEV : JVECTOR; PCTEMP : INTEGER; SRTEMP : DWORD; INITSTACK : INTEGER; INITPC : INTEGER; INITRECOVER : INTEGER; G_DOLLAR : INTE[1..6] of char; { jump vector } KRECORD = PACKED RECORD VTYPE : BYTE; SIZE : BYTE; VALUE : INTEGER; END; LLREC = PACKED ARRAY[0..1] OF DWORD; {****************************************************************************} {** DGER; CTL_RESETV : JVECTOR; DEBUGESCAPE : JVECTOR; BESPTEMP : INTEGER; AONOFF : BYTE; GONOFF : BYTE; GRAPHICSBASE : INTEGER; INITSR : DWORD; M68KTYPE : BYTE; MSYSFLAGS : BYTE; FLTPTHDW : BYTED      : INTEGER; { USER STACK POINTER } DREGS : ARRAY[0..7] OF INTEGER; AREGS : ARRAY[0..7] OF INTEGER; { CRT STUFF } CRTOPCODE : BYTE; CRTCHAR : CHAR; CRTPADDING1 : BYTE; CRTPROMPTSIZE: BYTE; CRTPROMPT : PA; {value} PROCEDURE UNITTOMSUS; { UNITTOMSUS DETERMINES THE MSUS THAT APPLIES TO THE GIVEN FILE SYSTEM UNIT NUMBER. ON INPUT, THE UNIT NUMBER IS REQUIRED AND ON OUTPUT THE MSUS AND RESULT CODE ARE RETURNED. INPUT: UNIT NUMBER IS IN TEMPL. OUTCKED ARRAY[1..4] OF CHAR; CRTPADDING2 : INTEGER; LASTLINEOP : BYTE; STAT0CHAR : CHAR; CRTPADDING3 : DWORD; { KEYBOARD STUFF } KBDSTATREG : BYTE; KBDCHAR : CHAR; KBDDUMMY : CHAR; { NOT USED } KBDTRANSCODE : BYTPUT: MSUS IS IN TEMPL2. RESULT CODE IS IN TEMPL3. RESULT CODE CONTENTS ARE: 0 = OK RETURN 1 = COULDN'T MAKE A DEFINITE CONVERSION. MSUS IS INVALID. } TYPE msus_type = packed record case integer of 1:(df : 0..7;E; { 0 = ALPHA, 1= SPECIAL,3= NON_ADV } { OTHER STUFF } UEXCPI : INTEGER; { ERROR TRAP IMPLANT ADDR } SYMBOLHOOK : JVECTOR; { HOOK INTO SYMBOL LOOKUP } ACCUMV : KRECORD; DATAV : KRECORD; BASE : DWORD; SSI { directory format } dt : 0..31; { device type } unum : byte; { unit number } scode : byte; { select code } baddr : byte); { bus address } 2:(pad1 : byte; vol : 0..ZE : INTEGER; RCOUNT : INTEGER; ETCODES : ARRAY[0..1] OF INTEGER; NUMET : BYTE; SCODE : BYTE; DSCODE : BYTE; TEMPD : CHAR; { DEBUG CI RUNLIGHT } TEMPR : CHAR; { TEMP RUNLIGHT } 15; { volume number } un : 0..15); { unit number } 3:(bytes : packed array [1..4] of char); end; PROCEDURE FSUNIT_MSUS(FSUNIT : unitnum; ANYVAR MSUS : msus_type); VAR f : fib; BEGIN if (fsunit<0) or (fsunit>ma OUTFLAGS : BYTE; LINECOUNT : DWORD; RECALLV : STR80P; TEMPS : ARRAY[1..4] OF INTEGER; SAVEHOOK : JVECTOR; INSTACK : ARRAY[1..4] OF INTEGER; OPSTACK : ARRAY[1..12] OF INTEGER; INBUF : STRING80; xunit) then escape(2); with unitable^[fsunit] do begin msus.df := 0; msus.scode := sc; msus.baddr := ba; msus.unum := du; case letter of 'B':begin { BUBBLE } msus.dt := 22; end; 'E':begin { EPROM } END; VAR OUTS : STR80P; DEBUGCRT : ^DBCINFO; DERR_INFO['ERR_INFO'] : INTEGER; DEBUGCOM : ^DEBUGCOMTYPE; function value(symbol: string255): integer; var modp: moddescptr; ptr, valueptr: addrec; found: boolean;  msus.dt := 20; msus.unum := dv; { bootrom uses unit, table uses volume } end; 'F':begin { 9885 } msus.dt := 6; end; 'G':begin { SRM } msus.df := 7; msus.dt := 1; end; 'H':begin { 9895 } ms begin {value} value := 0; found := false; modp := sysdefs; while (modp<>nil) and not found do with modp^ do begin ptr := defaddr; while (ptr.a 2 then escape(2); call(dam, uvid, fsunit, getvolumename); if (ioresult <> ord(inoerror)) or (strlen(uvid) = 0) or (dvrtemp2 < 8) then escape(2) else if dvrtemp2=8 then msus.dt := 16 elD     ED ARRAY[1..2] OF INTEGER); END; VAR I : INTEGER; RPROC : PREC; BEGIN SP:= OUTS; RPROC.I2[1]:=VALUE('MFS_FWRITESTRREAL'); { FIND THE ROUTINE } IF RPROC.I2[1]=0 THEN SP^ :='no R formatter' ELSE BEGIN TRY RPROC.Inction key } begin case data of { fix itf keycodes } 5: data:=56; { break=>pause } 6: data:=55; { stop } 7: data:=59; { select=>execute} 8: data:=57; { np enter=>enter} 17: { enter/print }2[2]:=0; { CLEAR STATIC LINK } SETSTRLEN(SP^,0); { CLEAR THE STRING } I:=1; { SET START POSITION } CALL(RPROC.REALPR,SP^,I,RP^,-1,-1); { CALL THE ROUTINE } RECOVER SP^ := 'not real'; END; END; procedure readkey;  if shift and control then { dump graphics } begin data:=50; debugcom^.kbdstatreg:=175; end else if shift then data:=49 { dump alpha } else data:=57; { enter } 20:begin {system/user} if shift then key:='U' else key:=se msus.dt := 17; end; 'S':begin { SCSI } msus.dt := 14; end; 'U':begin { 913X_A } msus.dt := 7; end; 'V':begin { 913X_B } msus.dt := 8; end; 'W':begin { 913X_C } msus.dt := 9; end;  var oldkbdisr : kbdhooktype; oldrpgisr : kbdhooktype; alldone : boolean; oldcaps : boolean; oldnonchar: char; procedure debugrpg(var kbdstatus, kbddata: byte; var dokey: boolean); var key: char; begin if doke otherwise escape(2); end; { case } end; END; { FSUNIT_MSUS } BEGIN WITH DEBUGCOM^ DO BEGIN TRY TEMPS[3] := 0; FSUNIT_MSUS(TEMPS[1],TEMPS[2]); RECOVER TEMPS[3] := 1; END; END; { DUMMY REVASM } PROCEDURE Dy then with debugcom^ do begin kbdstatreg:= kbdstatus; kbdtranscode:= 1; { special } alldone:= true; case not odd(kbdstatus div 16) of true: {shifted} { down arrow, up arrow } if kbddata >= 128 then kbdchar:= #34 else kbdchUMREVASM(ANYVAR INSP: INTEGER; ANYVAR SP:STR80P; ANYVAR FTYPE:INTEGER); TYPE REVPROC = PROCEDURE (ANYVAR INSP: INTEGER; VAR S:STRING; ANYVAR NXTP,FTYPE:INTEGER); PREC = RECORD CASE BOOLEAN OF TRUE :(RPROC : REVPROC); ar:= #35; false: {unshifted}{ right arrow, left arrow } if kbddata >= 128 then kbdchar:= #39 else kbdchar:= #38; end; end; end; { rpghandler } procedure debugkeys(var kbdstatus, kbddata: byte; var dokey: boolean); var  FALSE:(I2 : PACKED ARRAY[1..2] OF INTEGER); END; VAR TPROC:PREC; NXTP : INTEGER; BEGIN SP:= OUTS; TPROC.I2[1]:=VALUE('REVASM_MOD_REVASM'); { TRY TO FIND THE REAL REVASM } IF TPROC.I2[1]=0 THEN BEGIN SETSTRLEN(SP^,0); NXT i : integer; c : char; begin { debugkeys } if dokey then with langcom do begin status := kbdstatus; data := kbddata; extension:= not odd(kbdstatus div 8); shift := not odd(kbdstatus div 16); control := not odd(kbdstatusP:=INSP; END { SIGNAL NO DECODE } ELSE BEGIN TPROC.I2[2]:=0; { CLEAR STATIC LINK } CALL(TPROC.RPROC,INSP,SP^,NXTP,FTYPE); { CALL THE REVERSE ASSEMBLER } INSP:=NXTP; { OLD POINTER BECOMES NEW  div 32); call(langtable[langindex]^.semantics); debugcom^.kbdstatreg:= status; debugcom^.kbdtranscode:= 0; { 3.0 BUG FIX } alldone := true; CASE result OF nonadv_key, { have non advancing key } alpha_key, NONA_ALPHA_KEY {3.1 BUGFIX SFB--5/30/} END; END; PROCEDURE REALTOSTRING(ANYVAR RP:REALP; ANYVAR SP:STR80P); TYPE RSPROC = PROCEDURE(VAR R:STRING; VAR P2:INTEGER;X :REAL; W,D:SHORTINT); PREC = RECORD CASE BOOLEAN OF TRUE :(REALPR : RSPROC); FALSE:(I2 : PACK85} : begin debugcom^.kbdchar:= key; if (result=nonadv_key) OR {3.1 BUGFIX SFB--5/30/85} ((RESULT = NONA_ALPHA_KEY) AND NOT SHIFT) then begin keybuffer^.non_char:= key; alldone:=false; end; end; special_key: { have special fuE     'S'; kbdsysmode:=not shift; setstatus(6,key); if key='U' then if (menustate=m_sysnorm) or (menustate=m_sysshift) then begin menustate:=m_none; keybuffer^.echo:=true; keybufops(kdisplay,c); end; alldone:=falsetatus(i,' '); setrunlight(tempd); end; 4: for i:=0 to 5 do setstatus(i,' '); { clear status line } 5: setstatus(0,stat0char); 6: begin { display last line } setstrlen(inbuf,0); strwrite(inbuf,1,i,lastline^[1]:5); setstatus(0,' '); ; end; 21:begin {menu} alldone := false; if kbdsysmode and not control then begin call(crtllhook,cllclear,i,c); if menustate<=m_sysshift then menustate:=mstates[menustate,shift] else menustate:=m_none; keybuf for i:=1 to 5 do setstatus(i,inbuf[i]); end; otherwise end; end;{ dolastlineop } procedure docrtops; var i : integer; procedure putcursor; begin with debugcrt^ do begin if cursx>xmax then begin cursx:=xmin; curfer^.echo:=(menustate=m_none); case menustate of m_none : keybufops(kdisplay,c); m_sysnorm : call(crtllhook,clldisplay,sysmenu^,c); m_sysshift: call(crtllhook,clldisplay,sysmenushift^,c); otherwise end; end; sy:=cursy+1; end; if cursy>ymax then begin cursy:=ymax; call(dbcrthook,dbscrollup,debugcrt^); end; call(dbcrthook,dbgotoxy,debugcrt^); end; end; { putcursor } begin with debugcom^, debugcrt^ do if savesize>0 then case crtopco end; 22:begin data:=52; debugcom^.kbdstatreg:=191; end; { clr line } 23:begin data:=52; debugcom^.kbdstatreg:=175; end; { clr screen } otherwise end; { case data } debugcom^.kbdchar:= chr(data); debugcom^.kbdtranscode:=de of 0: call(dbcrthook,dbexcg,debugcrt^); { exchange display } 1: begin { putchr & advance cursor } c:=crtchar; call(dbcrthook,dbput,debugcrt^); cursx:=cursx+1; putcursor; end; 2: begin { write prompt } for i:=1 to cr 1; { special } end; ignored_key: alldone:=false; OTHERWISE {TO MAKE ISR MORE ROBUST- THE "BITBUCKET". SFB--5/30/85} end; end; { with langcom } end; { debugkeys } begin { readkey } alldone:= false; with langtable[langindex]^tpromptsize do begin c:=crtprompt[i]; call(dbcrthook,dbput,debugcrt^); cursx:=cursx+1; putcursor; end; end; 3: begin cursx:=xmin; cursy:=cursy+1; putcursor; end; 4: call(dbcrthook,dbinit,debugcrt^); 5: begin { clear crt &  do begin oldcaps:= kbdcapslock; kbdcapslock:= true; { force capslock } oldkbdisr:= kbdisrhook; kbdisrhook:= debugkeys; oldrpgisr:= rpgisrhook; rpgisrhook:= debugrpg; oldnonchar:= keybuffer^.non_char; keybuffer^.non_char:= ' ';homecursor } call(dbcrthook,dbclear,debugcrt^); cursx:=xmin; cursy:=ymin; putcursor; end; 6: call(dbcrthook,dbcline,debugcrt^); { clear to end of line } 7: begin cursx:=xmin; putcursor; end; 8: begin cursx:=cursx-1; putcursor;  repeat call(kbdpollhook,true) until alldone; kbdcapslock:= oldcaps; end; kbdisrhook:= oldkbdisr; rpgisrhook:= oldrpgisr; keybuffer^.non_char:= oldnonchar; end; { readkey } procedure dolastlineop; var tempc : char; end; 9: begin cursx:=cursx+1; putcursor; end; otherwise end; end; { docrtops } PROCEDURE DOINIT; VAR DONE: BOOLEAN; BEGIN { initialize } IF OUTS=NIL THEN NEW(OUTS); DEBUGCOM := ADDR(DERR_INFO); { allocate debugger crt wi : integer; begin with debugcom^ do case lastlineop of 0: begin tempc:= runlight; setrunlight(tempr); tempr:= tempc; end; 1: setrunlight(tempr); 2: begin tempd:= runlight; setrunlight('d'); end; 3: begin for i:=1 to 5 do setsindow } NEW(DEBUGCRT); WITH DEBUGCRT^ DO BEGIN XMIN:=0; YMIN:=0; XMAX:=SYSCOM^.CRTINFO.WIDTH-1; YMAX:=SYSCOM^.CRTINFO.HEIGHT-1; SAVESIZE:=-1; CALL(DBCRTHOOK,DBINFO,DEBUGCRT^); DONE:= SAVESIZE<=0; WHILE E      RIGHTS LEGEND Use, duplication, or disclosure by the Government is subject to restrictions as set forth in paragraph (b) (3) (B) of the Rights in Technical Data and Computer Software clause in DAR 7-104.9(a). HEWLETT-PACKARD COMPANY Fort Collins, Colorareadln(T); iocheck; end; end; 1: for i := i to pagesize-1 do pagebuffer[i] := nullchar; end; $iocheck on$ procedure UCSD_to_any(anyvar pagebuffer: pagebuftype; var T: text); label 1; type pageptr = ^pagebuftype; var i, j: integer; c: chardo *) $modcal$ $debug off, range off, ovflcheck off, stackcheck off, iocheck off$ $ALLOW_PACKED ON$ {JWS 3/31/87} module convert_text; import sysglobals, misc, asm; export const pagesize = 1024; type pagebuftype = packed arr; begin try i := 0; repeat c := pagebuffer[i]; if c = chr(dle) then begin i := i + 1; if i = pagesize then begin write(T, c); goto 1; end else begin c := pagebuffer[i]; if c > ' ' then write(T, ' ':ord(c)-ord(' ')); NOT DONE DO { ALLOCATE SPACE TO SWAP WINDOW } BEGIN IF SAVESIZE<4000 THEN DONE:=TRUE ELSE IF (XMAX-XMIN)>50 THEN XMIN:=XMAX-49 ELSE IF (YMAX-YMIN)>24 THEN YMIN:=YMAX-22 ELSE DONE:=TRUE; IF DONE THEN BEGIN NEWBYTES(SAVEAREA,SAVESIZE); Cay[0..pagesize-1] of char; procedure any_to_UCSD(var T: text; anyvar pagebuffer: pagebuftype); procedure UCSD_to_any(anyvar pagebuffer: pagebuftype; var T: text); implement procedure any_to_UCSD(var T: text; anyvar pagebuffer: pagebuftype); label 1; conALL(DBCRTHOOK,DBINIT,DEBUGCRT^); END ELSE CALL(DBCRTHOOK,DBINFO,DEBUGCRT^); END; { WHILE } END; { WITH } END; { DOINIT } procedure callsyscode(i : integer); begin case i of -1: DOINIT; 0 : DOCRTOPS; 1 : call(st strsize = 120; {arbitrary choice} type str = string[strsize]; strptr = ^str; charptr = ^ char; var i,j: integer; s: str; sp: strptr; endline: boolean; k : integer; {SFB} fp : fibp; {togglegraphicshook); 2 : call(dumpalphahook); 3 : call(dumpgraphicshook); 4 : WITH DEBUGCOM^ DO REALTOSTRING(TEMPS[1],TEMPS[2]); 5 : WITH DEBUGCOM^ DO DUMREVASM(TEMPS[1],TEMPS[2],TEMPS[3]); 6 : BEEP; 7 : READKEY; 8 : call(toggleSFB} procedure iocheck; begin if ioresult <> ord(inoerror) then begin if ioresult = ord(ieof) then ioresult := ord(inoerror); goto 1; end; end; begin fp := addr(T); {ready to check for space replace SFB} i := 0; endlinealphahook); 9 : dolastlineop; 10: UNITTOMSUS; otherwise end; { case } end; { callsyscode } end; { module sysbug } import sysglobals,loader,sysbug; procedure realdebugger(p1,p2,p3: integer); external; {****** PROGRAM INSTALLDEBUGGER  := false; while (i < pagesize - strsize) do begin if endline then begin sp := addr(pagebuffer[i],-1); read(T, sp^); j := strlen(sp^); if fp^.feft = uxfile_eft then {then space replace tabs SFB} for k:=1 to j do **************} begin callsyscode(-1); { initialize sysbug } if realdebugger<>debugger then begin debugger:=realdebugger; realdebugger(0,0,0); { initialize debugger } markuser; end; end. if sp^[k] = chr(tab) then sp^[k] := ' ' {space char}; charptr(sp)^ := eol; iocheck; i := i + j; end else begin read(T, s); iocheck; if fp^.feft = uxfile_eft then {then space replace tabs SFB} for k:=1 to st (* (c) Copyright Hewlett-Packard Company, 1983. All rights are reserved. Copying or other reproduction of this program except for archival purposes is prohibited without the prior written consent of Hewlett-Packard Company. RESTRICTEDrlen(s) do if s[k] = chr(tab) then s[k] := ' ' {space char}; moveleft(s[1], pagebuffer[i], strlen(s)); i := i + strlen(s); end; endline := eoln(T); iocheck; if endline then begin pagebuffer[i] := eol; i := i + 1; F      i := i + 1; if i = pagesize then goto 1; c := pagebuffer[i]; end; end; j := i; while (c<>eol) and (c<>nullchar) do begin j := j + 1; if j = pagesize then c := nullchar else c := pagebuffer[j]; end; write(it; end; end; procedure wendbuffer; begin { append access only } with fp^ do begin { write all but last sector } fbufchanged := true; if (bufend-flastpos)>sectorsize then begin bufend := bufend - sectorsize; flushbufT, pageptr(addr(pagebuffer[i]))^:j-i); if c = nullchar then goto 1; writeln(T); i := j + 1; until i = pagesize; 1: recover if escapecode <> -10 then escape(escapecode); end; end. {module convert_text} fer; moveleft(fbuffer[bufend-flastpos],fbuffer[0],sectorsize); end else flushbuffer; fleof := fpos + 1; fmodified := true; if fleof>fpeof then begin { move the physical end of file } fpos := ((fleof + 256) div 2$SYSPROG$ $DEBUG OFF, RANGE OFF, OVFLCHECK OFF, STACKCHECK OFF$ $ALLOW_PACKED ON$ {JWS 3/31/87} program installascii; module asciimodule; import sysglobals, asm; export procedure asciiam(fp : fibp; request: amrequesttype; anyvar buffer:window; bufs56) * 256; call(unitable^[funit].dam,fp^,funit,STRETCHIT); if fleof>fpeof then begin ioresult := ord(ieof); escape(0); end; fpos := fleof - 1; end; flastpos := bufend; bufparams; end; end; procedure wnextbyte(c:char); begin { appeize,position:integer); implement const buflength = fblksize; sectorsize= 256; procedure asciiam(fp: fibp; request: amrequesttype; anyvar buffer: window; bufsize,position: integer); var bufend : integer; procedure bufparams; begin with fnd access only } with fp^ do begin if fpos>=bufend then wendbuffer; fbuffer[fpos - flastpos] := c; fbufchanged := true; fpos := fpos + 1; fleof := fpos; fmodified := true; end; end; { wnextbyte } procedure wrp^ do if (flastpos+buflength)>fpeof then bufend := fpeof else bufend := flastpos + buflength; end; procedure rendfile; begin if request<>readtoeol then ioresult := ord(ieof); fp^.fpos := fp^.fleof; { fix fpos } escape(0)iteendline; var tposit, j : integer; tbufchanged : boolean; {added for 3.1 BUGFIX DTS #181 SFB--6/4/85} begin with fp^ do begin if freptcnt=0 then begin { zero length record } if odd(fpos) then wnextbyte(' '); wnextbyt; end; procedure flushbuffer; begin ioresult := 0; with fp^, unitable^[funit] do begin { write out the buffer } call(tm,fp,WRITEBYTES,fbuffer,bufend-flastpos,flastpos); if ioresult<>0 then escape(0); fbufchanged := e(chr(0)); wnextbyte(chr(0)); end else begin { have some data } tbufchanged := fbufchanged; {3.1 BUGFIX #081 SFB--6/4/85} tposit := fpos; j := tposit - freptcnt - 2; { rewrite the record size } if j=bufend then loadbuffer(tposit); fpos := tposit; freptcnt := 0; if tbufchanged then fbufchanged := true; {3.1 BUGFIXREADBYTES,fbuffer,bufend-flastpos,flastpos); if ioresult<>0 then escape(0); end; end; procedure seekposit(posit: integer); begin with fp^ do begin if (posit=bufend) then loadbuffer(posit); fpos:=pos #181 SFB-6/4/85} end; end; end; { writeendline } procedure wendfile; begin with fp^ do begin if freptcnt>0 then writeendline; { write logical end of file marker } if odd(fpos) then wnextbyte(' '); { pad to even F     ytes } if fpos>=fleof then rendfile else seekposit(fpos); count := min(bufsize-i, bufend-fpos, freptcnt); moveleft(fbuffer[fpos-flastpos],buffer[i],count); i := i + count; freptcnt := freptcnt - count; fpos := fpos + count; end; end;dtoeol then buffer[0] := chr(0); if fbufchanged then begin { close last record } fpos := fleof; wendfile; fpos := abs(position); { restore fpos } end; if position<0 then begin { seqential read } if request= { while } feoln := (freptcnt<0); if not feoln then fpos := -fpos; end; end; { readchars } procedure readstring; var i, count : integer; begin i := 0; with fp^ do begin if freptcnt>0 then whilereadbytes then readchars else readstring; end { seqential read } else begin { positioned read } if position>fp^.fleof then rendfile else seekposit(position); getrecsize; if request=readbytes then readposition } if fleof=fleof then rendfile else seekposit(fpos); count := min(bufsize-i, bufend-fpos, freptcnt); moveleft(fbuffer[fpos-flastpos],buffer[i+1],count); freptcnt := freptcnt - count; i := i + count; f begin if v1=fleof then rendfile; if (fpos>=bufend) then loadbuffer(fpos); rnextbyte := fbuffer[fpos - flastpos]; fpos := fpos + 1; end; end; procedure getrecsize; begin with fp^ do begin if 0) and (bufsize>0) then begin { start a new record } if odd(fpos) then wnextbyte(' '); { pad to even size } wnextbyte(chr(255)); wnextbyte(chr(255)); { dummy count field } end; i:=0; while i127 then rendfile; freptcnt := (freptcnt * 256) + ord(rnextbyte); end; end; procedure readchars; var count, i : integer; begin  { write data character(s) } if fpos>=bufend then wendbuffer; count := min(bufsize-i, bufend-fpos, 32767-freptcnt); if count<=0 then { too many characters for the record } begin ioresult := ord(ibadformat); escape(0); end; moveleft(buffer[i],f{ readchars } with fp^ do begin i:=0; if bufsize=1 then begin { single character read } if freptcnt=0 then begin buffer[0] := ' '; freptcnt := -1; end else begin buffer[0] := rnextbyte; freptcnt := freptcnt - 1; end; ebuffer[fpos-flastpos],count); fpos := fpos + count; freptcnt := freptcnt + count; i := i + count; fbufchanged := true; end; { while } fleof := fpos; end; { with } end; { write chars } begin { asciiam } ioresult:=0;nd else { multi character read } while i0 then writechars { normal write } else begin { rewrite } flastpos := 0; bufparams; freptcnt := 0; writech: integer); label 1, 2, 3, 4; const pagesize = 2*fblksize; var ptr: charptr; count, index: shortint; c: char; procedure initpage(position: integer); const {FOR OPTIMIZATION FOR 3.1B BUGFIX LAF/SFB--5/15/85} z_arr_size = 64; iterars; end; end; flush: if fbufchanged then begin fpos := fleof; wendfile; end; writeeol: { end the line } begin if position<>0 then writeendline else begin { zero length record at start of file } fl_m1 = fblksize div z_arr_size - 1; type zero_array = array[0..z_arr_size-1] of char; zero_array_p = ^zero_array; const zeros = zero_array [z_arr_size of #0]; var i: integer; start: integer; {FOR OPTIMIZATION FOR 3.1B BUGastpos := 0; bufparams; freptcnt := 0; wnextbyte(chr(0)); wnextbyte(chr(0)); end; end; otherwise ioresult := ord(ibadrequest); end; { case } end; { with } recover if escapecode<0 then escape(escapecode); end; { FIX LAF/SFB--5/15/85} zero_p: zero_array_p; {FOR 3.1B OPTIMIZATION} begin with fp^ do begin fpos := position + pagesize - position mod pagesize; if fpos > fleof then begin if fpos > fpeof then begin call(unitable^[funasciiam } end; { ascii module } import asciimodule,sysglobals,loader; begin { installascii } amtable^[ASCIIFILE] := asciiam; suffixtable^[ASCIIFILE] := 'ASC'; efttable^[ASCIIFILE] := 1; markuser; end. { rev 16 A } it].dam, fp^, funit, stretchit); if fpos > fpeof then begin ioresult := ord(ieof); goto 1; end; end; fleof := fpos; fmodified := true; end; fpos := position; index := fpos mod fblksize; if index = 0 then {OPTIMIZATION FOR 3.1B BUGFI (* (c) Copyright Hewlett-Packard Company, 1983. All rights are reserved. Copying or other reproduction of this program except for archival purposes is prohibited without the prior written consent of Hewlett-Packard Company. RESTRICTEDX LAF/SFB--5/15/85} begin {DO "FAST INIT" OF FBUFFER TO 512 #0s LAF/SFB 5/15/85} zero_p := addr(zeros); start := 0; for i:=0 to iter_m1 do begin moveright(zero_p^,fbuffer[start],z_arr_size); start := start + z_arr_size; end;  RIGHTS LEGEND Use, duplication, or disclosure by the Government is subject to restrictions as set forth in paragraph (b) (3) (B) of the Rights in Technical Data and Computer Software clause in DAR 7-104.9(a). HEWLETT-PACKARD COMPANY Fort Collins, Colora end else {NORMAL "ANY SIZE" INIT TO #0s, AS IN 3.0} for i := index to fblksize-1 do fbuffer[i] := chr(0); fbufchanged := true; flastpos := fpos; end; end; procedure putbuffer; label 2; const linesize = 256; do *) $modcal$ $debug off, range off, ovflcheck off, stackcheck off, iocheck off$ $ALLOW_PACKED ON$ {JWS 3/31/87} program UCSD_AM_INIT; module UCSD_am; {UCSD access method} import sysglobals, asm, misc, sysdevs; export var block, i, j, bytes: integer; save: packed array[0..linesize-1] of char; begin with fp^ do begin block := flastpos div fblksize; if odd(block) and (fbuffer[fblksize-1] <> chr(0)) then begin j := fblksize-2; while j >= f procedure init_UCSD_am; implement (* ACCESS METHOD FOR UCSD TEXT FILES *) {The assumption of this access method is that direct access will not happen} procedure textam(fp: fibp; request: amrequesttype; anyvar buffer: window; buffsize, positionblksize-1-linesize do if fbuffer[j] = eol then begin bytes := fblksize-1-j; moveleft(fbuffer[j+1], save, bytes); for i := j+1 to fblksize-1 do fbuffer[i] := chr(0); goto 2; end else j := j - 1; bytes := 0; G      begin with fp^ do begin buffer[0] := chr(count); if count > 0 then feoln := false; flastpos := fpos; goto 1 end; end; procedure getbuffer; begin with fp^ do begin flastpos := fpos; if (fpos + fblksize) > in 2: if freptcnt < -1 then begin c := ' '; freptcnt := freptcnt + 1; feoln := false; end else begin 3: if index = 0 then getbuffer; c := fbuffer[index]; if c = chr(0) then {end of page} begin fpos := fpos - fpos mod pagfleof then if request = readtoeol then endline else ioresult := ord(ieof) else call(unitable^[funit].tm, fp, readbytes, fbuffer, fblksize, fpos); if ioresult <> ord(inoerror) then goto 1; end; end; begin {TEXTAM} ioresuesize + pagesize; index := 0; goto 3; end; fpos := fpos + 1; index := index + 1; if index = fblksize then index := 0; if c = chr(dle) then {space compression} begin if index = 0 then getbuffer; c := fbuffer[index];  {give up, line too long to carry over} end else bytes := 0; 2: call (unitable^[funit].tm, fp, writebytes, fbuffer, fblksize, block*fblksize); if ioresult <> ord(inoerror) then goto 1; fpos := (block+1)*fblksize; index := 0;lt := ord(inoerror); {3.0 BUG FIX--SFB 4/24/85} with fp^ do case request of flush: begin putenviron; flushbuffer; call(unitable^[funit].tm, fp, flush, buffer, buffsize, position); end; writeeol: begin c := eol; te if bytes > 0 then begin initpage(fpos+bytes); moveleft(save, fbuffer, bytes); end else fbufchanged := false; if not odd(block) then {3.1B BUGFIX--LAF/SFB 5/15/85} initpage(fpos); {ALWAYS INIT SECOND HALF OF PAGE} extam(fp, writebytes, c, 1, position); end; writebytes: begin fpos := position; index := fpos mod fblksize; putenviron; ptr := addr(buffer); while buffsize > 0 do begin c := ptr^; ptr := addr(ptr^, 1); bnd; end; procedure putenviron; begin if fp^.fleof < pagesize then begin initpage(0); putbuffer; initpage(fblksize); putbuffer; end; end; procedure putchar(c: char); begin with fp^ do begin uffsize := buffsize - 1; if c = ' ' then if freptcnt >= 0 then freptcnt := freptcnt + 1 else goto 4 else begin if freptcnt >= 0 then begin flushindent; if c <> eol then freptcnt := -1; end else if c = eol then freptcnt := 0; if index = 0 then initpage(fpos); fbuffer[index] := c; fpos := fpos + 1; index := index + 1; if index = fblksize then putbuffer; end; end; procedure flushindent; begin with fp^ do if freptcnt <> 0 then begin if 4: if index = 0 then initpage(fpos); {MAY BE DONE AGAIN IN PUTBUFFER} fbuffer[index] := c; fpos := fpos + 1; index := index + 1; if index = fblksize then putbuffer; end; end; flastpos := fpos; end; {writebytes} readtoeol, read freptcnt = 1 then putchar(' ') else if freptcnt > 1 then begin putchar(chr(dle)); putchar(chr(freptcnt+ord(' '))); end; freptcnt := 0; end; end; procedure flushbuffer; var block: integer; begin with fp^ do bytes: begin ptr := addr(buffer); count := 0; if position = 0 then {reset has been done} begin flushbuffer; {if reset after writing} fpos := pagesize; index := 0; fle begin fpos := flastpos; index := fpos mod fblksize; flushindent; while fbufchanged do begin block := flastpos div fblksize; putbuffer; if not odd(block) then initpage((block+1)*fblksize); end; end; end; procedure endline; of := fleof + (-fleof) mod pagesize; end else begin fpos := position; index := fpos mod fblksize; end; if request = readtoeol then begin ptr^ := chr(0); ptr := addr(ptr^, 1); end; while buffsize > 0 do begH      fpos := fpos + 1; index := index + 1; if index = fblksize then index := 0; freptcnt := 31 - ord(c); goto 2; end; if c = eol then if request = readtoeol then begin fpos := fpos - 1; endline; end else begin feoln ******************* Copyright Hewlett-Packard Company, 1994. All rights are reserved. Copying or other reproduction of this product except for archival purposes is prohibited without the prior written consent of Hewlett-Packard Company. := true; c := ' '; end else feoln := false; end; ptr^ := c; ptr := addr(ptr^, 1); count := count + 1; buffsize := buffsize - 1; end; if request = readtoeol then endline; flastpos := fpos; end; {reRESTRICTED RIGHTS LEGEND Use, duplication, or disclosure by the Government is subject to restrictions as set forth in paragraph (b) (3) (B) of the Rights in Technical Data and Computer Software clause in DAR 7-104.9(a). HEWLETT-PACKARD COMPANY Fort Colliadbytes} otherwise ioresult := ord(ibadrequest); end; 1: end; procedure init_UCSD_am; begin suffixtable^[textfile] := 'TEXT'; {text file suffix} amtable^ [textfile] := textam; {UCSD text file format} efttable^ [textfns, Colorado ile] := -5570; {DCD Pascal "UCSD TEXT" file} end; end; {UCSD text access method} import UCSD_am, loader; begin {program install UCSD AM} init_UCSD_am; markuser; {DEW 11/23/88, Fix defect FSDdt01557} end.  This floppy contains the source for various Pascal Workstation drivers (A804XDVR, KEYS, NONUSKBD1, NONUSKBD2, BAT, CLOCK, DGL_ABS, DGL_REL, IODECLARATIONS, REALS, REVASM, DEBUGGER, ASC_AM, CONVERT, TEXT_AM). The modcal version of the PaWS Pascal compiler is required to build the various drivers. A copy of this compiler can be found on the SCSI: source floppy disk. A stream file (MAKE_ALL.TEXT) which shows how to build and link the drivers is also included.  This floppy contains the source for various Pascal Workstation drivers (A804XDVR, KEYS, NONUSKBD1, NONUSKBD2, BAT, CLOCK, DGL_ABS, DGL_REL, IODECLARATIONS, REALS, REVASM, DEBUGGER, ASC_AM, CONVERT, TEXT_AM). The modcal version of the PaWS Pascal compiler is required to build the various drivers. A copy of this compiler can be found on the SCSI: source floppy disk. A stream file (MAKE_KEYS.TEXT) which shows how to build and link the drivers is also included. **********************************************H     I     I     J     J     K     K     L     L