diff options
| author | Lars-Dominik Braun <lars@6xq.net> | 2019-02-11 11:49:19 +0100 |
|---|---|---|
| committer | Lars-Dominik Braun <lars@6xq.net> | 2019-02-11 11:49:39 +0100 |
| commit | 98cab31fc3659e33aef260efca55bf9f1753164c (patch) | |
| tree | f1affa84049ef9b268e6c4f521f000478b0f3a8e /devel/misc | |
| parent | 71e2b36ccd05ea678e62e32ee6245df2b8d6ac17 (diff) | |
| download | eumel-src-98cab31fc3659e33aef260efca55bf9f1753164c.tar.gz eumel-src-98cab31fc3659e33aef260efca55bf9f1753164c.tar.bz2 eumel-src-98cab31fc3659e33aef260efca55bf9f1753164c.zip | |
Add source files from Michael
Diffstat (limited to 'devel/misc')
| -rw-r--r-- | devel/misc/unknown/src/0DISASS.ELA | 1110 | ||||
| -rw-r--r-- | devel/misc/unknown/src/ASSEMBLE.ELA | 387 | ||||
| -rw-r--r-- | devel/misc/unknown/src/COPYDS.ELA | 294 | ||||
| -rw-r--r-- | devel/misc/unknown/src/DS4.ELA | 268 | ||||
| -rw-r--r-- | devel/misc/unknown/src/PRIVS.ELA | 485 | ||||
| -rw-r--r-- | devel/misc/unknown/src/TABINFO.ELA | 117 | ||||
| -rw-r--r-- | devel/misc/unknown/src/TRACE.ELA | 552 | ||||
| -rw-r--r-- | devel/misc/unknown/src/XLIST.ELA | 143 | ||||
| -rw-r--r-- | devel/misc/unknown/src/XSTATUS.ELA | 188 | ||||
| -rw-r--r-- | devel/misc/unknown/src/Z80.ELA | 495 |
10 files changed, 4039 insertions, 0 deletions
diff --git a/devel/misc/unknown/src/0DISASS.ELA b/devel/misc/unknown/src/0DISASS.ELA new file mode 100644 index 0000000..954fdf7 --- /dev/null +++ b/devel/misc/unknown/src/0DISASS.ELA @@ -0,0 +1,1110 @@ +PACKET eumel 0 code disassembler DEFINES (* M.Staubermann, M„rz/April 86 *)
+ disass 0 code,
+(* disass object,
+ disass address,
+ disass module nr, *)
+ disass 0,
+ ADD,
+ hex16,
+ hex8 ,
+ integer,
+ denoter,
+ opcode,
+ seg,
+ addr,
+ end addr,
+ local base ,
+ bool result ,
+ code word line :
+
+LET packet data segment = 0 ,
+ local data segment = 1 ,
+ first elan address = 13322 ,
+ begin of stringtable = 1024 ,
+ begin of nametable = 4096 ,
+ end of nametable = 19455 ,
+ begin of permanent table = 19456 ;
+
+INT VAR address, segment, lbas ;
+
+PROC local base (INT CONST i) :
+ lbas := i (* -1 = lbas unbekannt *)
+ENDPROC local base ;
+
+TEXT PROC code word line :
+ code words
+ENDPROC code word line ;
+
+PROC code word line (TEXT CONST text) :
+ code words := text
+ENDPROC code word line ;
+
+PROC seg (INT CONST s) :
+ segment := s
+ENDPROC seg ;
+
+PROC addr(INT CONST a) :
+ address := a
+ENDPROC addr ;
+
+INT PROC addr :
+ address
+ENDPROC addr ;
+
+BOOL PROC bool result :
+ was bool result
+ENDPROC bool result ;
+
+PROC bool result (BOOL CONST b) :
+ was bool result := b
+ENDPROC bool result ;
+
+PROC end addr (INT CONST e) :
+ end address := e
+ENDPROC end addr ;
+
+PROC disass 0 code (INT CONST seg, INT VAR addr, PROC (TEXT CONST) writeln) :
+ TEXT VAR taste ;
+ BOOL VAR addr out := TRUE ,
+ output permitted := TRUE,
+ is packet ;
+ INT VAR size, used, mod nr, a, b, m ;
+ storage (size, used) ;
+ echo := FALSE ;
+ init list file ;
+ segment := seg ;
+ address := addr ;
+ mod nr := -1 ;
+ was bool result := FALSE ;
+ REP
+ IF output permitted
+ THEN IF addr out
+ THEN out (" ") ;
+ out (hex16 (address)) ;
+ out (" "8""8""8""8""8""8"") ;
+ ELSE cout (ln)
+ FI
+ FI ;
+ taste := incharety ;
+ disass one statement ;
+ SELECT code (taste) OF
+{l}CASE 108 : addr out := FALSE
+{d}CASE 100 : get command ("gib kommando:") ; do command
+{f}CASE 102 : out (""13""5"Filename: "+filename+ "." + text(filenumber)+" ")
+{z}CASE 122 : out (""13""5"Fileline: "+text (lines (list file)) + " ")
+{a}CASE 97 : addr out := TRUE
+{e}CASE 101 : echo := NOT echo
+{s}CASE 115 : storage(size,used);out(""13""5"System-Storage: "+text(used)+" ")
+{h}CASE 104 : out (""13""5"Heapsize: " + text (heapsize) + " ")
+{m}CASE 109 : out (""13""5"Modulnr: " + text (mod nr) + " ")
+{W}CASE 87, 81: output permitted := TRUE
+{S}CASE 83 : output permitted := FALSE
+ CASE 27 : IF incharety <> "" THEN taste := "" FI(* Wegen Steuertasten *)
+ ENDSELECT ;
+ arith 16 ;
+ address INCR 1 ;
+ arith 15 ;
+ IF (address AND 31) = 0
+ THEN storage (size, used) ;
+ FI ;
+ BOOL CONST ende erreicht :: end address <> 0 CAND
+ real (address) >= real (end address) ;
+ UNTIL ende erreicht OR taste = ""27"" OR taste = ""129"" OR used > size PER ;
+ IF used > size
+ THEN writeln ("Abbruch wegen Speicherengpass!")
+ ELIF taste = ""27""
+ THEN writeln ("Abbruch mit ESC")
+ FI ;
+ addr := address .
+
+code word :
+ get word (segment, address) .
+
+disass one statement :
+ a := address ;
+ divrem 256 (a, b) ;
+ IF segment = 2
+ THEN m := pos (segment 2 adresses, ""0"" + code (b) + code (a) + ""0"") ;
+ IF m <= LENGTH segment 2 adresses - 4
+ THEN IF code (segment 2 adresses SUB (m + 4)) <= a
+ THEN IF code (segment 2 adresses SUB (m + 4)) = a
+ THEN is packet :=
+ code (segment 2 adresses SUB (m + 3)) <= b
+ ELSE is packet := TRUE
+ FI
+ ELSE is packet := FALSE
+ FI
+ ELSE is packet := FALSE
+ FI
+ ELSE m := pos (segment 3 adresses, ""0"" + code (b) + code (a) + ""0"") ;
+ IF m <= LENGTH segment 3 adresses - 4
+ THEN IF code (segment 3 adresses SUB (m + 4)) <= a
+ THEN IF code (segment 3 adresses SUB (m + 4)) = a
+ THEN is packet :=
+ code (segment 3 adresses SUB (m + 3)) <= b
+ ELSE is packet := TRUE
+ FI
+ ELSE is packet := FALSE
+ FI
+ ELSE is packet := FALSE
+ FI
+ FI ;
+ IF m > 0 AND end address = 0 AND addr <> address
+ THEN taste := ""129"" ;
+ LEAVE disass one statement
+ ELIF m > 0
+ THEN m := (m - 1) DIV 3 + 1 ;
+ IF segment = 2
+ THEN mod nr := segment 2 modules ISUB m
+ ELSE mod nr := segment 3 modules ISUB m
+ FI ;
+ writeln (" ") ;
+ writeln ("Modulnummer " + process module nr (mod nr, is packet)) ;
+ writeln ("Top of Stack: " + hex16 (codeword)) ;
+ arith 16 ;
+ address INCR 1 ;
+ arith 15 ;
+ writeln (" ")
+ FI ;
+ codewords := hex16 (address) + " " ;
+ codewords CAT hex16 (code word) + " " ;
+ TEXT CONST opc := opcode ;
+ WHILE length (codewords) < 30 REP
+ codewords CAT " "
+ PER ;
+ writeln (codewords + opc) .
+
+ENDPROC disass 0 code ;
+
+PROC init list file :
+ forget (filename + "." + text (filenumber), quiet) ;
+ list file := sequentialfile (output, filename + "." + text (filenumber)) ;
+ maxlinelength (list file, 9999) ;
+ list line ("Addr Opco Data Data Data Data Opcode Parameter") ;
+ENDPROC init list file ;
+
+PROC list line (TEXT CONST zeile) :
+ IF lines (list file) > 4000
+ THEN file number INCR 1 ;
+ init list file
+ FI ;
+ putline (list file, zeile) ;
+ IF echo
+ THEN putline (zeile)
+ FI
+ENDPROC list line ;
+
+PROC disass object :
+ TEXT VAR object name ;
+ INT VAR nth object , code address ;
+ put ("Filename:") ;
+ getline (filename) ;
+ filenumber := 0 ;
+ end address := 0 ;
+ REP
+ clear error ;
+ enablestop ;
+ page ;
+ put ("Name des zu Disassemblierenden Objekts:") ;
+ getline (object name) ;
+ changeall(object name, " ", "") ;
+ putline ("Bitte Gewuenschtes Objekt von vorne an abzaehlen und ESC q druecken.") ;
+ pause (5) ;
+ disablestop ;
+ help (object name) ;
+ UNTIL NOT iserror PER ;
+ enablestop ;
+ page ;
+ put ("Nummer des Objekts:") ;
+ get (nth object) ;
+ code address := code start (object name, nth object) ;
+ lbas := -1 ;
+ disass 0 code (code segment, code address, PROC (TEXT CONST) list line) ;
+ edit (filename + ".0")
+ENDPROC disass object ;
+
+PROC disass module nr :
+ INT VAR mod nr , code address ;
+ end address := 0 ;
+ put ("Filename:") ;
+ getline (filename) ;
+ filenumber := 0 ;
+ page ;
+ put ("Modulnummer:") ;
+ get (mod nr) ;
+ code address := code start (mod nr) ;
+ lbas := -1 ;
+ IF code address = -1
+ THEN putline ("Unbelegte Modulnummer")
+ ELSE disass 0 code (code segment, code address, PROC (TEXT CONST) listline) ;
+ edit (filename + ".0")
+ FI
+ENDPROC disass module nr ;
+
+PROC disass address :
+ INT VAR code segment, code address ;
+ TEXT VAR eingabe ;
+ put ("Filename:") ;
+ getline (filename) ;
+ file number := 0 ;
+ page ;
+ put ("Code Segment (2 o. 3):") ;
+ get (code segment) ;
+ put ("Startadresse (Hex) :") ;
+ getline (eingabe) ;
+ code address := integer (eingabe) ;
+ put ("Endadresse (Hex) :") ;
+ getline (eingabe) ;
+ end address := integer (eingabe) ;
+ lbas := -1 ;
+ disass 0 code (code segment, code address, PROC (TEXT CONST) listline) ;
+ edit (filename + ".0")
+ENDPROC disass address ;
+
+FILE VAR list file ;
+TEXT VAR file name ;
+INT VAR op data,
+ file number ,
+ first module line := 200 ,
+ anzahl steuerzeichen,
+ anzahl zeros,
+ call data ,
+ long data,
+ low,
+ op1,
+ op 2,
+ word,
+ ln := -1,
+ end address := 0,
+ high ,
+ data base := 0 ;
+BOOL VAR echo, was bool result := FALSE ;
+TEXT VAR code words := "" ,
+ segment 2 modules,
+ segment 2 adresses,
+ segment 3 modules,
+ segment 3 adresses;
+
+TEXT PROC opcode :
+ TEXT VAR temp := " " ;
+ word := get word (segment, address) ;
+ op1 := (word AND 31744) DIV 1024 ;
+ op2 := (word AND 768) DIV 128 ;
+ low := word AND 255 ;
+ ln := -1 ;
+ replace (temp, 1, address) ;
+ high := code (temp SUB 2) ;
+ op data := word AND -31745 ;
+ long data := (word AND 768) * 2 + (word AND 255) ;
+ call data := word AND 1023 ;
+ IF word < 0
+ THEN IF word = -3
+ THEN LEAVE opcode WITH "Block unlesbar"
+ ELIF word = -1
+ THEN LEAVE opcode WITH ""
+ ELSE long data INCR 256 ;
+ op2 INCR 1 ;
+ call data INCR 1024
+ FI
+ FI ;
+ IF op1 = 31 AND op2 = 7
+ THEN op1 := (word AND 127) DIV 4 ;
+ op2 := (word AND 3) * 2 ;
+ low := -1 ;
+ long data := next word ;
+ call data := long data ;
+ op data := long data ;
+ IF (word AND 128) = 128 THEN op2 INCR 1 FI ;
+ "LONGA " + opc
+ ELSE opc
+ FI .
+ENDPROC opcode ;
+
+TEXT PROC opc :
+ BOOL CONST previous bool result :: was bool result ;
+ was bool result := FALSE ;
+ SELECT op1 OF
+ CASE 0 : process ln
+ CASE 1 : process ln long
+ CASE 2 : "MOV " + two params (6,6)
+ CASE 3 : "INC1 " + one param (1)
+ CASE 4 : "DEC1 " + one param (1)
+ CASE 5 : "INC " + two params (1,1)
+ CASE 6 : "DEC " + two params (1,1)
+ CASE 7 : "ADD " + three params (1,1,1)
+ CASE 8 : "SUB " + three params (1,1,1)
+ CASE 9 : "CLEAR " + one param (6)
+ CASE 10 : was bool result := TRUE ; "TEST " + one param (6)
+ CASE 11 : was bool result := TRUE ; "EQU " + two params (1,1)
+ CASE 12 : was bool result := TRUE ; "LSEQ " + two params (1,1)
+ CASE 13 : "FMOV " + two params (2,2)
+ CASE 14 : "FADD " + three params (2,2,2)
+ CASE 15 : "FSUB " + three params (2,2,2)
+ CASE 16 : "FMULT " + three params (2,2,2)
+ CASE 17 : "FDIV " + three params (2,2,2)
+ CASE 18 : was bool result := TRUE ; "FLSEQ " + two params (2,2)
+ CASE 19 : "TMOV " + two params (3,3)
+ CASE 20 : was bool result := TRUE ; "TEQU " + two params (3,3)
+ CASE 21 : was bool result := TRUE ; "ULSEQ " + two params (1,1)
+ CASE 22 : process accds
+ CASE 23 : "REF " + two params (0,0)
+ CASE 24 : process subs
+ CASE 25 : process sel
+ CASE 26 : "PPV " + one param (0)
+ CASE 27 : "PP " + one param (0)
+ CASE 28 : process br
+ CASE 29 : process brlong
+ CASE 30 : "CALL " + process module nr (call data, FALSE)
+ OTHERWISE op 31
+ ENDSELECT .
+
+process ln :
+ IF previous bool result
+ THEN "BT " + branch address
+ ELSE ln := long data ;
+ "LN " + text (long data)
+ FI .
+
+process ln long :
+ long data INCR 2048 ;
+ IF previous bool result
+ THEN "BTLONG " + branch address
+ ELSE ln := long data ;
+ "LNLONG " + text (long data)
+ FI .
+
+process br :
+ IF previous bool result
+ THEN "BF " + branch address
+ ELSE "BR " + branch address
+ FI .
+
+process brlong :
+ long data INCR 2048 ;
+ IF previous bool result
+ THEN "BFLONG " + branch address
+ ELSE "BRLONG " + branch address
+ FI .
+
+process accds :
+ "ACCDS (DSid:" + hex16 (op data) + denoter (opdata, 8) + ", BOUND-Result:" +
+ params ("0") .
+
+process subs :
+ INT CONST elem len :: long data, limit1 :: next word, index :: next word,
+ base :: next word, result :: next word ;
+ "SUBS (Elem.len:" + text (elem len) + ", Limit:" + text (limit1 + 1) +
+ ", Index:" + hex16 (index) + denoter (index, 1) + ", Base:" + hex16 (base) +
+ ", Result:" + hex16 (result) + denoter (result, 0) + ")".
+
+process sel :
+ INT CONST offset :: next word, result1 :: next word ;
+ "SEL (Base:" + hex16 (op data) + ", Offset:" + hex16 (offset) +
+ ", Result:" + hex16 (result1) + denoter (result1, 0) + ")".
+
+op31 :
+SELECT op 2 OF
+ CASE 0 : was bool result := TRUE ;
+ "IS (""" + code (low) + """, " + params ("0") (* 7C *)
+ CASE 1 : "STIM (" + hex8 (low) + ", " + params ("6") (* FC *)
+ CASE 2 : "MOVX (" + hex8 (low) + ", " + params ("66") (* 7D *)
+ CASE 3 : "PUTW (" + hex8 (low) + ", " + params ("77") (* FD *)
+ CASE 4 : "GETW (" + hex8 (low) + ", " + params ("77") (* 7E *)
+ CASE 5 : data base := ((""0"" + code (low)) ISUB 1) ;
+ "PENTER (" + hex8 (low) +")" (* FE *)
+ CASE 6 : "ESC " + esc code (* 7F *)
+ OTHERWISE"???????" (* FF *)
+ENDSELECT .
+
+ENDPROC opc ;
+
+TEXT PROC branch address :
+ INT VAR branch byte := long data DIV 256 ;
+ branch byte := (branch byte + high) AND 15 + (high AND 240) ;
+ hex8 (branch byte) + hex8 (long data AND 255)
+ENDPROC branch address ;
+
+INT PROC next word :
+ arith 16 ;
+ address INCR 1 ;
+ arith 15 ;
+ INT CONST w :: get word (segment, address) ;
+ codewords CAT hex16 (w) + " " ;
+ w
+ENDPROC next word ;
+
+TEXT PROC one param (INT CONST type) :
+ "(" + hex16 (op data) + denoter (op data, type) + ")"
+ENDPROC one param ;
+
+TEXT PROC three params (INT CONST type a, type b, type c) :
+ INT CONST word b :: next word, word c :: next word ;
+ "(" + hex16 (op data) + denoter (op data, type a) + ", " +
+ hex16 (word b) + denoter (word b, type b) + ", " +
+ hex16 (word c) + denoter (word c, type c) + ")"
+ENDPROC three params ;
+
+TEXT PROC two params (INT CONST type a, type b) :
+ INT CONST word b :: next word ;
+ "(" + hex16 (op data) + denoter (op data, type a) + ", " +
+ hex16 (word b) + denoter (word b, type b) + ")"
+ENDPROC two params ;
+
+TEXT PROC denoter (INT CONST offset, type) :
+ IF offset < 0 AND lbas = -1 THEN LEAVE denoter WITH " <LOCAL>"
+ ELIF type = 7 THEN LEAVE denoter WITH ""
+ ELIF type >= 2 AND type <= 5 OR type = 8 THEN
+ LEAVE denoter WITH " <" +
+ data object (offset, data base, type) + ">"
+ FI ;
+ INT VAR i, byte, word1, word ;
+ IF offset < 0
+ THEN word := get word (local data segment, (offset AND 32767) ADD lbas)
+ ELSE word := get word (packet data segment, data base ADD offset)
+ FI ;
+ TEXT VAR x, t := " <" + hex16 (word) ;
+ IF address < first elan address
+ THEN IF word >= begin of stringtable CAND word <= end of nametable
+ THEN string pointer
+ ELIF word > 9 AND word < 32
+ THEN t CAT ":""""" + text (word) + """"""
+ ELIF word >= 32 AND word < 127
+ THEN t CAT ":""" + code (word) + """"
+ FI ;
+ FI ;
+ IF type = 0 COR type = 6
+ THEN BOOL VAR text sinnvoll := FALSE ,
+ real sinnvoll := FALSE ,
+ bool sinnvoll := word = -1 OR word = 0 OR word = 1 ;
+ IF type = 0
+ THEN IF offset < 0
+ THEN word1 := get word (local data segment,
+ lbas ADD (offset AND 32767) ADD 1)
+ ELSE word1 := get word (packet data segment,
+ data base ADD offset ADD 1) ;
+ FI ;
+ text sinnvoll := keine steuerzeichen AND (word1 AND 255) < 80 ;
+ real sinnvoll := vorzeichen ok AND nur digits
+ FI ;
+ try type
+ FI ;
+ t + ">" .
+
+string pointer :
+ IF word >= begin of name table
+ THEN word INCR 2
+ FI ;
+ IF (cdbint (word) AND 255) < 100
+ THEN x := cdbtext (word) ;
+ IF pos (x, ""0"", ""31"", 1) = 0 CAND
+ pos (x, ""127"", ""213"", 1) = 0 CAND
+ pos (x, ""220"", code (255), 1) = 0
+ THEN t CAT ":""" ;
+ t CAT x ;
+ t CAT """"
+ FI
+ FI .
+
+try type :
+ IF bool sinnvoll
+ THEN t CAT ":" ;
+ t CAT data object (offset, data base, 4)
+ FI ;
+ IF real sinnvoll
+ THEN t CAT ":" ;
+ t CAT x
+ FI ;
+ IF text sinnvoll
+ THEN t CAT ":" ;
+ t CAT text result
+ FI .
+
+keine steuerzeichen :
+ TEXT VAR text result := data object (offset, data base, 3) ;
+ anzahl steuerzeichen < 4 AND anzahl zeros < 2 AND word1 <> -1 .
+
+vorzeichen ok :
+ (word AND 240) = 0 OR (word AND 240) = 128 .
+
+nur digits :
+ IF (word AND 15) > 9 THEN FALSE
+ ELSE x := data object (offset, data base, 2) ;
+ FOR i FROM 2 UPTO 7 REP
+ byte := code (x SUB i) ;
+ IF (byte AND 240) > 249 OR (byte AND 15) > 9
+ THEN LEAVE nur digits WITH FALSE
+ FI
+ PER ;
+ TRUE
+ FI .
+
+ENDPROC denoter ;
+
+TEXT PROC esc code :
+ SELECT low OF
+ CASE 0 : "RTN "
+ CASE 1 : "RTNT "
+ CASE 2 : "RTNF "
+ CASE 3 : "REPTXT?"
+ CASE 4 : "TERM "
+ CASE 5 : "??????"
+ CASE 6 : "KE "
+ CASE 7 : "??????"
+ CASE 8 : "CRD (" + params ("11")
+ CASE 9 : "BCRD (" + params ("11")
+ CASE 10 : "CWR (" + params ("111")
+ CASE 11 : "ECWR (" + params ("111")
+ CASE 12 : "CTT (" + params ("01")
+ CASE 13 : was bool result := TRUE ; "GETC (" + params ("311")
+ CASE 14 : was bool result := TRUE ; "FNONBL (" + params ("131")
+ CASE 15 : "DREM256 (" + params ("11")
+ CASE 16 : "AMUL256 (" + params ("11")
+ CASE 17 : "??????"
+ CASE 18 : was bool result := TRUE ; "ISDIG (" + params ("1")
+ CASE 19 : was bool result := TRUE ; "ISLD (" + params ("1")
+ CASE 20 : was bool result := TRUE ; "ISLCAS (" + params ("1")
+ CASE 21 : was bool result := TRUE ; "ISUCAS (" + params ("1")
+ CASE 22 : "GADDR (" + params ("111")
+ CASE 23 : was bool result := TRUE ; "GCADDR (" + params ("111")
+ CASE 24 : was bool result := TRUE ; "ISSHA (" + params ("1")
+ CASE 25 : "SYSGEN "
+ CASE 26 : "GETTAB "
+ CASE 27 : "PUTTAB "
+ CASE 28 : "ERTAB "
+ CASE 29 : "EXEC " + process module nr (next word, FALSE)
+ CASE 30 : "PPROC " + process module nr (next word, FALSE)
+ CASE 31 : "PCALL (" + params ("1")
+ CASE 32 : "CASE (" + params ("17")
+ CASE 33 : "MOVXX (" + params ("700")
+ CASE 34 : "ALIAS (" + params ("088")
+ CASE 35 : "MOVIM (" + params ("76")
+ CASE 36 : was bool result := TRUE ; "FEQU (" + params ("22")
+ CASE 37 : was bool result := TRUE ; "TLSEQ (" + params ("33")
+ CASE 38 : "FCOMPL (" + params ("22")
+ CASE 39 : "COMPL (" + params ("11")
+ CASE 40 : "IMULT (" + params ("111")
+ CASE 41 : "MULT (" + params ("111")
+ CASE 42 : "DIV (" + params ("111")
+ CASE 43 : "MOD (" + params ("111")
+ CASE 44 : "ISUB (" + params ("311")
+ CASE 45 : "replace (" + params ("311")
+ CASE 46 : "code (" + params ("31")
+ CASE 47 : "code (" + params ("13")
+ CASE 48 : "SUB (" + params ("313")
+ CASE 49 : "subtext (" + params ("3113")
+ CASE 50 : "subtext (" + params ("313")
+ CASE 51 : "replace (" + params ("313")
+ CASE 52 : "CAT (" + params ("33")
+ CASE 53 : "length (" + params ("31")
+ CASE 54 : "pos (" + params ("331")
+ CASE 55 : "pos (" + params ("3311")
+ CASE 56 : "pos (" + params ("33111")
+ CASE 57 : "stranalyze (" + params ("1113111")
+ CASE 58 : "pos (" + params ("33311")
+ CASE 59 : "??????"
+ CASE 60 : "out (" + params ("3")
+ CASE 61 : "cout (" + params ("1")
+ CASE 62 : "outsubtext (" + params ("31")
+ CASE 63 : "outsubtext (" + params ("311")
+ CASE 64 : "inchar (" + params ("3")
+ CASE 65 : "incharety (" + params ("3")
+ CASE 66 : "pause (" + params ("1")
+ CASE 67 : "getcursor (" + params ("11")
+ CASE 68 : "catinput (" + params ("33")
+ CASE 69 : "nilspace (" + params ("8")
+ CASE 70 : ":= DD (" + params ("88")
+ CASE 71 : "forget (" + params ("8")
+ CASE 72 : "typeDI (" + params ("81")
+ CASE 73 : "ItypeD (" + params ("81")
+ CASE 74 : "heapsize (" + params ("81")
+ CASE 75 : "enablestop "
+ CASE 76 : "disablestop "
+ CASE 77 : "seterrorstop (" + params ("1")
+ CASE 78 : was bool result := TRUE ; "iserror "
+ CASE 79 : "clearerror "
+ CASE 80 : "IpcbI (" + params ("11")
+ CASE 81 : "pcbII (" + params ("11")
+ CASE 82 : "setclock (" + params ("52")
+ CASE 83 : "??????"
+ CASE 84 : "control (" + params ("1111")
+ CASE 85 : "blockout (" + params ("81111")
+ CASE 86 : "blockin (" + params ("81111")
+ CASE 87 : "nextdspage (" + params ("811")
+ CASE 88 : "IpagesDT (" + params ("851")
+ CASE 89 : "storage (" + params ("11")
+ CASE 90 : "sysop (" + params ("1")
+ CASE 91 : "ARITH15 "
+ CASE 92 : "ARITH16 "
+ CASE 93 : "heapsize (" + params ("1")
+ CASE 94 : "collectheapgarbage "
+ CASE 95 : "??????"
+ CASE 96 : "FSLD (" + params ("121")
+ CASE 97 : "GEXP (" + params ("21")
+ CASE 98 : "SEXP (" + params ("12")
+ CASE 99 : "floor (" + params ("22")
+ CASE 100: "RSUB (" + params ("312")
+ CASE 101: "replace (" + params ("312")
+ CASE 102: "clock (" + params ("12")
+ CASE 103: "setclock (" + params ("2")
+ CASE 104: "pcb (" + params ("511")
+ CASE 105: "pcb (" + params ("511")
+ CASE 106: "clock (" + params ("52")
+ CASE 107: "status (" + params ("51")
+ CASE 108: "unblock (" + params ("5")
+ CASE 109: "block (" + params ("5")
+ CASE 110: "haltprocess (" + params ("5")
+ CASE 111: "createprocess (" + params ("55")
+ CASE 112: "eraseprocess (" + params ("5")
+ CASE 113: "send (" + params ("5181")
+ CASE 114: "wait (" + params ("518")
+ CASE 115: "call (" + params ("5181")
+ CASE 116: "cdbint (" + params ("11")
+ CASE 117: "cdbtext (" + params ("13")
+ CASE 118: "nextactive (" + params ("1")
+ CASE 119: "PW (" + params ("111")
+ CASE 120: "GW (" + params ("111")
+ CASE 121: "XOR (" + params ("111")
+ CASE 122: "pingpong (" + params ("5181")
+ CASE 123: was bool result := TRUE ; "exists (" + params ("5")
+ CASE 124: "AND (" + params ("111")
+ CASE 125: "OR (" + params ("111")
+ CASE 126: "session (" + params ("1")
+ CASE 127: "send (" + params ("55181")
+ CASE 128: "definecollector (" + params ("5")
+ CASE 129: "id (" + params ("11")
+ OTHERWISE "??????"
+ ENDSELECT .
+
+ENDPROC esc code ;
+
+TEXT PROC params (TEXT CONST types) :
+ INT VAR i , word ;
+ TEXT VAR t := "" ;
+ FOR i FROM 1 UPTO LENGTH types REP
+ word := next word ;
+ t CAT hex16 (word) ;
+ t CAT denoter (word, int (types SUB i)) ;
+ IF i <> LENGTH types THEN t CAT ", " FI
+ PER ;
+ t + ") " .
+
+ENDPROC params ;
+
+PROC init module tables :
+ INT VAR i, j ;
+ TEXT VAR t := " " ;
+ segment 2 modules := "" ;
+ segment 2 adresses := ""0"" ;
+ segment 3 modules := "" ;
+ segment 3 adresses := ""0"" ;
+ i := -1 ;
+ REP
+ i INCR 1 ;
+ cout (i) ;
+ j := getword (0, i + 512) ;
+ IF j <> -1 CAND i <> 216 CAND i <> 217
+ THEN replace (t, 1, i) ;
+ segment 2 modules CAT t ;
+ replace (t, 1, j) ;
+ segment 2 adresses CAT t + ""0""
+ ELIF i < 256
+ THEN i := 255
+ ELIF i < 320
+ THEN i := 319
+ FI
+ UNTIL j = -1 CAND i > 320 PER ;
+ FOR i FROM 1280 UPTO 2047 REP
+ cout (i) ;
+ j := getword (0, i + 512) ;
+ IF j <> -1
+ THEN replace (t, 1, i) ;
+ segment 3 modules CAT t ;
+ replace (t, 1, j) ;
+ segment 3 adresses CAT t + ""0""
+ FI
+ UNTIL j = -1 PER
+ENDPROC init module tables ;
+
+TEXT PROC process module nr (INT CONST module number, BOOL CONST is packet) :
+ TEXT VAR object specification , mod nr := text (module number, 5) ;
+ IF module number < 0
+ THEN IF lbas = -1
+ THEN "LOCAL PROC"
+ ELSE "LOCAL:" + process module nr (getword (local data segment, lbas + (module number AND 32767)), is packet)
+ FI
+ ELSE
+ INT VAR code address := code start (module number) ;
+ IF one of compilers own module numbers
+ THEN object specification := "CDL"
+ ELIF elan defined internal
+ THEN SELECT module number OF
+ CASE 256 : object specification := "compiler (INT CONST, FILE VAR, TEXT CONST, INT VAR, BOOL CONST, BOOL CONST, BOOL CONST, BOOL CONST, BOOL CONST, BOOL CONST, BOOL CONST, BOOL CONST)"
+ CASE 257 : object specification := "outtext (TEXT CONST, INT CONST)"
+ CASE 258 : object specification := "outline (INT CONST)"
+ CASE 259 : object specification := "syntaxerror (TEXT CONST)"
+ CASE 260 : object specification := ":= (FILE VAR, FILE CONST)"
+ ENDSELECT
+ ELIF exists sorted module number table
+ THEN object specification := binary search (module number, is packet)
+ ELIF exists unsorted module number table
+ THEN FILE VAR f := sequentialfile (modify, "table.hash") ;
+ to firstrecord (f) ;
+ WHILE NOT eof (f) CAND subtext (f, 33, 37) <> mod nr REP
+ cout (lineno (f)) ;
+ down (f)
+ PER ;
+ IF eof (f) AND subtext (f, 33, 37) <> mod nr THEN
+ IF is packet
+ THEN object specification := "Paketinitialisierung"
+ ELSE object specification := "Hidden PROC/OP"
+ FI
+ ELSE object specification := compress (subtext (f, 1, 15)) +
+ specifications (begin of permanent table + int (subtext (f, 22, 25)))
+ FI
+ ELIF no elan module number
+ THEN object specification := "Objekt ohne Modulnummer!"
+ FI ;
+ was bool result := pos (object specification , "--> BOOL") <> 0 ;
+ text (module number) + " $" + hex8 (code segment) +
+ hex16 (code address) + " " + object specification
+ FI .
+
+one of compilers own module numbers :
+ module number < 256 .
+
+elan defined internal :
+ module number > 255 AND module number < 261 .
+
+exists sorted module number table :
+ exists ("table.module") AND module number > 319 .
+
+exists unsorted module number table:
+ exists ("table.hash") AND module number > 319 .
+
+no elan module number :
+ module number < 320 .
+
+ENDPROC process module nr ;
+
+TEXT PROC binary search (INT CONST nr, BOOL CONST is packet) :
+ TEXT VAR record , text nr := text (nr, 5) ;
+ INT VAR first line, last line , mid , i ;
+ FILE VAR f := sequentialfile (modify, "table.module") ;
+ first line := first module line ;
+ last line := lines (f) ;
+ REP
+ mid := (first line + last line) DIV 2 ;
+ to line (f, mid) ;
+ IF text nr > subtext (f, 33, 37) THEN first line := mid + 1
+ ELSE last line := mid
+ FI
+ UNTIL first line = last line PER ;
+ to line (f, first line) ;
+ IF subtext (f, 33, 37) = text nr
+ THEN record := compress (subtext (f, 1, 15)) +
+ specifications (begin of permanent table + int (subtext (f, 22, 25)))
+ ELSE is hidden module
+ FI ;
+ record .
+
+is hidden module:
+ IF NOT is packet
+ THEN to line (f, first line - 1)
+ FI ;
+ FOR i FROM int (subtext (f, 22, 25)) + begin of permanent table DOWNTO begin of permanent table
+ WHILE cdbint (i) <> -2 REP PER ;
+ IF i <= begin of permanent table
+ THEN IF is packet
+ THEN record := "Paketinitialisierung"
+ ELSE record := "Hidden PROC/OP"
+ FI
+ ELSE IF is packet
+ THEN record := "Paketinitialisierung: " +
+ cdbtext (cdbint (i + 1) + 2)
+ ELSE record := "Hidden PROC/OP (Packet " +
+ cdbtext (cdbint (i + 1) + 2) + ")"
+ FI
+ FI .
+
+ENDPROC binary search ;
+
+TEXT PROC data object (INT CONST address, data base, denoter type) :
+ TEXT VAR t , result ;
+ INT VAR i , laenge , zeichen, index, version, segment, new address ;
+ IF address < 0 AND lbas = -1
+ THEN LEAVE data object WITH "LOCAL"
+ ELIF address < 0
+ THEN segment := local data segment ;
+ new address := (address AND 32767) ADD lbas
+ ELSE segment := packet data segment ;
+ new address := data base ADD address
+ FI ;
+ SELECT denoter type OF
+ CASE 1 : int denoter
+ CASE 2 : real denoter
+ CASE 3 : text denoter
+ CASE 4 : bool denoter
+ CASE 5 : task denoter
+ CASE 8 : dataspace denoter
+ OTHERWISE "DENOTERTYPE(" + text (denoter type) + ")?"
+ ENDSELECT .
+
+bool denoter :
+ IF get word (segment, new address) = 0
+ THEN "TRUE"
+ ELSE "FALSE"
+ FI .
+
+int denoter :
+ hex16 (get word (segment, new address)) .
+
+real denoter :
+ t := "12345678" ;
+ FOR i FROM 0 UPTO 3 REP
+ replace (t, i + 1, get word (segment, new address ADD i))
+ PER ;
+ disablestop ;
+ t := text (t RSUB 1) ;
+ IF iserror THEN clearerror ;
+ enablestop ;
+ "9.999999999999e126"
+ ELSE enablestop ;
+ t
+ FI .
+
+text denoter :
+ t := copied text var (segment, new address) ;
+ result := "" ;
+ anzahl steuerzeichen := 0 ;
+ anzahl zeros := 0 ;
+ FOR i FROM 1 UPTO length (t) REP
+ zeichen := code (t SUB i) ;
+ IF zeichen = 34 THEN result CAT """"""
+ ELIF zeichen = 251 OR zeichen > 31 AND zeichen < 127 OR
+ zeichen > 213 AND zeichen < 224 THEN result CAT code (zeichen)
+ ELSE result CAT """" ;
+ result CAT text (zeichen) ;
+ result CAT """" ;
+ anzahl steuerzeichen INCR 1 ;
+ IF zeichen = 0
+ THEN anzahl zeros INCR 1
+ FI
+ FI
+ PER ;
+ """" + result + """" .
+
+task denoter :
+ index := get word (segment, new address) ;
+ version := get word (segment, new address ADD 1) ;
+ hex16 (index) + " " + hex16 (version) + ":" + taskname (index, version) .
+
+dataspace denoter :
+ result := " " ;
+ replace (result, 1, get word (segment, new address)) ;
+ TEXT CONST two bytes :: hex8 (code (result SUB 2)) + " " +
+ hex8 (code (result SUB 1)) ;
+ IF result = ""255""255""
+ THEN two bytes + ":Not Init"
+ ELIF result = ""0""0""
+ THEN two bytes + ":nilspace"
+ ELSE two bytes + ":" + taskname (code (result SUB 2), -1)
+ FI .
+ENDPROC data object ;
+
+TEXT PROC copied text var (INT CONST segment, address) :
+ TEXT VAR result ;
+ INT VAR i, laenge ;
+ result := " " ;
+ replace (result, 1, getword (segment, address ADD 1)) ;
+ laenge := code (result SUB 1) ;
+ IF laenge = 0
+ THEN ""
+ ELIF laenge = 255
+ THEN INT CONST basis :: -32765 ADD (getword (segment, address)-3) DIV 2 ;
+ laenge := ((result SUB 2) + code ((getword (segment, address
+ ADD 2) AND 255))) ISUB 1 ;
+ result := "" ;
+ FOR i FROM 1 UPTO laenge DIV 2 REP
+ result CAT " " ;
+ replace (result, i, getword (1, basis + i -1))
+ PER ;
+ IF LENGTH result <> laenge
+ THEN result CAT code (getword (1, basis + laenge DIV 2))
+ FI ;
+ result
+ ELSE TEXT CONST first char :: result SUB 2 ;
+ result := "" ;
+ FOR i FROM 1 UPTO (laenge-1) DIV 2 REP
+ result CAT " " ;
+ replace (result, i, getword (segment, address ADD (i + 1))) ;
+ PER ;
+ IF LENGTH result + 1 <> laenge
+ THEN first char + result + code (getword (segment, address ADD
+ ((laenge-1) DIV 2 + 2)) AND 255)
+ ELSE first char + result
+ FI
+ FI
+ENDPROC copied text var ;
+
+TEXT PROC task name (INT CONST id, vers) :
+ TEXT VAR result ;
+ DATASPACE VAR ds := nilspace ;
+ BOUND STRUCT (INT index, version) VAR t1 := ds ;
+ BOUND TASK VAR t2 := ds ;
+ IF id = 0
+ THEN result := "niltask"
+ ELSE t1.index := id AND 255 ;
+ IF vers = -1
+ THEN t1.version := 0 ;
+ t1.version := pcb (t2, 10)
+ ELSE t1.version := vers
+ FI ;
+ disablestop ;
+ IF exists (t2)
+ THEN result := """" + name (t2) + """"
+ ELSE result := "-"
+ FI ;
+ FI ;
+ forget (ds) ;
+ enable stop ;
+ result
+ENDPROC task name ;
+
+INT PROC integer (TEXT CONST hex addr) :
+ INT VAR i ;
+ REAL VAR summe := 0.0 ;
+ FOR i FROM 1 UPTO length (hex addr) REP
+ summe := summe * 16.0 ;
+ summe INCR real (digit)
+ PER ;
+ IF summe > 32767.0 THEN int (summe - 65536.0)
+ ELSE int (summe)
+ FI.
+
+digit :
+ TEXT CONST char := hex addr SUB i ;
+ IF char >= "a" THEN code (char) - 87
+ ELIF char >= "A" THEN code (char) - 55
+ ELSE code (char) - 48
+ FI
+ENDPROC integer ;
+
+TEXT PROC hex8 (INT CONST wert) :
+ hex digit (wert DIV 16) +
+ hex digit (wert AND 15)
+ENDPROC hex8 ;
+
+TEXT PROC hex16 (INT CONST wert) :
+ TEXT VAR t := " " ;
+ replace (t, 1, wert) ;
+ hex digit (code (t SUB 2) DIV 16) +
+ hex digit (code (t SUB 2) AND 15) +
+ hex digit (code (t SUB 1) DIV 16) +
+ hex digit (code (t SUB 1) AND 15)
+ENDPROC hex16 ;
+
+TEXT PROC hex digit (INT CONST wert) :
+ IF wert < 10 THEN code (wert + 48)
+ ELSE code (wert + 55)
+ FI
+ENDPROC hex digit ;
+
+INT OP ADD (INT CONST left, right) :
+ arith 16 ;
+ INT CONST result :: left + right ;
+ arith 15 ;
+ result
+ENDOP ADD ;
+
+PROC disass0 :
+TEXT VAR key ;
+IF exists ("table.module")
+ THEN FILE VAR f := sequentialfile (modify, "table.module") ;
+ tofirstrecord (f) ;
+ down (f, " 322 ") ;
+ first module line := lineno (f) ;
+FI ;
+REP
+ page ;
+ putline ("++++++++++++++++++++++++ EUMEL0 - Code Disassembler ++++++++++++++++++++") ;
+ line (3) ;
+ putline (" 0 ......... Ende") ;
+ putline (" 1 ......... Objekt nach Name auswaehlen und disassemblieren") ;
+ putline (" 2 ......... Nach Modulnummer auswaehlen und disassemblieren") ;
+ putline (" 3 ......... Adressbereich disassemblieren") ;
+ putline (" 4 ......... Denoter aus Staticarea (Segment 0) ausgeben") ;
+ putline (" 5 ......... Codestart zur Modulnummer errechnen") ;
+ putline (" 6 ......... Modultabelle ergaenzen") ;
+ line ;
+ put ("Wahl:") ;
+ REP inchar (key) UNTIL key >= "0" AND key <= "6" PER ;
+ out (key) ;
+ line (2) ;
+ SELECT int (key) OF
+ CASE 0 : LEAVE disass 0
+ CASE 1 : disass object
+ CASE 2 : disass module nr
+ CASE 3 : disass address
+ CASE 4 : put denoter
+ CASE 5 : convert module number
+ CASE 6 : erweitere modul tabelle
+ ENDSELECT
+PER .
+
+erweitere modul tabelle :
+ INT VAR i, j ;
+ key := " " ;
+ FOR i FROM LENGTH segment 3 modules DIV 2 + 1280 UPTO 2047 REP
+ cout (i) ;
+ j := get word (0, 512 + i) ;
+ IF j <> -1
+ THEN replace (key, 1, i) ;
+ segment 3 modules CAT key ;
+ replace (key, 1, j) ;
+ segment 3 adresses CAT key + ""0"" ;
+ FI
+ UNTIL j = -1 PER.
+
+convert module number :
+ line (2) ;
+ INT VAR mod nr ;
+ put ("Modulnummer:") ;
+ get (mod nr) ;
+ mod nr := code start (mod nr) ;
+ IF mod nr = -1
+ THEN putline ("Unbelegte Modulnummer")
+ ELSE put ("Adresse:") ; put (hex16 (mod nr)) ; line ;
+ put ("Segment:") ; put (code segment) ; line
+ FI ;
+ putline ("- Taste -") ;
+ pause.
+
+put denoter :
+ line (2) ;
+ put ("PENTER(xx) in Hex:") ;
+ getline (key) ;
+ INT VAR base :: integer (key), typ ;
+ put ("Offset in Hex:") ;
+ getline (key) ;
+ typ := integer (key) ;
+ put ("TYPE (INT, REAL, TEXT, BOOL, TASK, DATASPACE):") ;
+ getline (key) ;
+ IF key = "INT" THEN typ := 1
+ ELIF key = "REAL" THEN typ := 2
+ ELIF key = "TEXT" THEN typ := 3
+ ELIF key = "BOOL" THEN typ := 4
+ ELIF key = "TASK" THEN typ := 5
+ ELIF key = "DATASPACE" THEN typ := 8
+ ELSE typ := 0
+ FI ;
+ lbas := -1 ;
+ putline (data object (typ, (""0"" + code (base)) ISUB 1, typ)) ;
+ putline ("- Taste -") ;
+ pause .
+
+ENDPROC disass 0 ;
+
+init module tables ;
+disass 0
+
+ENDPACKET eumel 0 code disassembler ;
diff --git a/devel/misc/unknown/src/ASSEMBLE.ELA b/devel/misc/unknown/src/ASSEMBLE.ELA new file mode 100644 index 0000000..7675dc4 --- /dev/null +++ b/devel/misc/unknown/src/ASSEMBLE.ELA @@ -0,0 +1,387 @@ +(***Assembler fuer 8080,8085,Z80***)
+
+PROC regh:
+ IF pos(in,"A",4) = (pos(in,",")+1) THEN out(printer,"F");
+ELIF pos(in,"B",4) = (pos(in,",")+1) THEN out(printer,"8");
+ELIF pos(in,"C",4) = (pos(in,",")+1) THEN out(printer,"9");
+ELIF pos(in,"D",4) = (pos(in,",")+1) THEN out(printer,"A");
+ELIF pos(in,"E",4) = (pos(in,",")+1) THEN out(printer,"B");
+ELIF pos(in,"H",4) = (pos(in,",")+1) THEN out(printer,"C");
+ELIF pos(in,"L",4) = (pos(in,",")+1) THEN out(printer,"D");
+ELIF pos(in,"M",4) = (pos(in,",")+1) OR pos(in,"m") = (pos(in,",")+1)
+ THEN out(printer,"E") FI
+ENDPROC regh.
+
+PROC regl:
+ IF pos(in,"A",4) > (pos(in,",")+0) THEN out(printer,"7");
+ELIF pos(in,"B",4) > (pos(in,",")+0) THEN out(printer,"0");
+ELIF pos(in,"C",4) > (pos(in,",")+0) THEN out(printer,"1");
+ELIF pos(in,"D",4) > (pos(in,",")+0) THEN out(printer,"2");
+ELIF pos(in,"E",4) > (pos(in,",")+0) THEN out(printer,"3");
+ELIF pos(in,"H",4) > (pos(in,",")+0) THEN out(printer,"4");
+ELIF pos(in,"L",4) > (pos(in,",")+0) THEN out(printer,"5");
+ELIF pos(in,"M",4) > (pos(in,",")+0) OR pos(in,"m") > (pos(in,",")+0)
+ THEN out(printer,"6") FI
+ENDPROC regl.
+ (*************************)
+ (*Autor:M.Staubermann *)
+BOOL VAR ad,number,falsch; (*Version:1.2.2 *)
+ad:=FALSE; (*Datum:7.12.82 *)
+number:=FALSE; (*************************)
+falsch:=FALSE;
+INT VAR count,fehler;
+TEXT VAR hilf,in,startaddresse::"0000";
+hilf:=" ";
+count:=0;
+fehler:=0;
+hilf:=" ";
+commanddialogue(FALSE);
+forget("maschinencode");
+FILE VAR printer:=sequentialfile(output,"maschinencode");
+forget("assemb");
+FILE VAR ass:=sequentialfile(modify,"assemb");
+forget("errors");
+FILE VAR fehlerliste:=sequentialfile(output,"errors");
+commanddialogue(TRUE);
+line;
+putline(" gib assembler kommando :");
+putline(" edit");
+pause(10);
+edit("assemb");
+tofirstrecord(ass);
+putline(" gib assembler kommando :");
+putline(" debug");
+pause(10);
+line;
+put (" ");
+put(printer,"Line: Add: Code:");
+line(printer);
+hexbeginn;
+
+ REPEAT
+ fehler:=fehler+1;
+ out(printer,text(fehler,4));
+ cout(fehler);
+ out(printer," ");
+ hex;
+ readrecord(ass,in);
+ forward(ass);
+ out(printer," ");
+ IF pos(in,"NOP") > 0 THEN out(printer,"00");
+ELIF pos(in,"HLT") > 0 THEN out(printer,"76");
+ELIF compress(in)="DI" THEN out(printer,"F3");
+ELIF pos(in,"EI") > 0 THEN out(printer,"FB");
+ELIF pos(in,"CMC") > 0 THEN out(printer,"3F");
+ELIF pos(in,"CMA") > 0 THEN out(printer,"2F");
+ELIF pos(in,"STC") > 0 THEN out(printer,"37");
+ELIF pos(in,"DAA") > 0 THEN out(printer,"27");
+ELIF pos(in,"RRC") > 0 THEN out(printer,"0F");
+ELIF pos(in,"RLC") > 0 THEN out(printer,"07");
+ELIF pos(in,"RAL") > 0 THEN out(printer,"17");
+ELIF pos(in,"RAR") > 0 THEN out(printer,"1F");
+ELIF pos(in,"XCHG")> 0 THEN out(printer,"EB");
+ELIF pos(in,"XTHL")> 0 THEN out(printer,"E3");
+ELIF pos(in,"SPHL")> 0 THEN out(printer,"F9");
+ELIF pos(in,"ADI") > 0 THEN out(printer,"C6");number:=TRUE;
+ELIF pos(in,"ACI") > 0 THEN out(printer,"CE");number:=TRUE;
+ELIF pos(in,"SUI") > 0 THEN out(printer,"D6");number:=TRUE;
+ELIF pos(in,"SBI") > 0 THEN out(printer,"DE");number:=TRUE;
+ELIF pos(in,"ANI") > 0 THEN out(printer,"E6");number:=TRUE;
+ELIF pos(in,"XRI") > 0 THEN out(printer,"EE");number:=TRUE;
+ELIF pos(in,"ORI") > 0 THEN out(printer,"F6");number:=TRUE;
+ELIF pos(in,"CPI") > 0 THEN out(printer,"FE");number:=TRUE;
+ELIF compress(in)="STA"THEN out(printer,"32");ad:=TRUE;
+ELIF compress(in)="LDA"THEN out(printer,"3A");ad:=TRUE;
+ELIF pos(in,"SHLD")> 0 THEN out(printer,"22");ad:=TRUE;
+ELIF pos(in,"LHLD")> 0 THEN out(printer,"2A");ad:=TRUE;
+ELIF pos(in,"PCHL")> 0 THEN out(printer,"E9");
+ELIF pos(in,"JMP") > 0 THEN out(printer,"C3");ad:=TRUE;
+ELIF pos(in,"JC") > 0 THEN out(printer,"DA");ad:=TRUE;
+ELIF pos(in,"JNC") > 0 THEN out(printer,"D2");ad:=TRUE;
+ELIF pos(in,"JZ") > 0 THEN out(printer,"CA");ad:=TRUE;
+ELIF pos(in,"JNZ") > 0 THEN out(printer,"C2");ad:=TRUE;
+ELIF compress(in)="JM" THEN out(printer,"FA");ad:=TRUE;
+ELIF compress(in)="JP" THEN out(printer,"F2");ad:=TRUE;
+ELIF pos(in,"JPE") > 0 THEN out(printer,"EA");ad:=TRUE;
+ELIF pos(in,"JPO") > 0 THEN out(printer,"E2");ad:=TRUE;
+ELIF pos(in,"CALL")> 0 THEN out(printer,"CD");ad:=TRUE;
+ELIF pos(in,"OUT") > 0 THEN out(printer,"D3");number:=TRUE;
+ELIF pos(in,"CC") > 0 THEN out(printer,"DC");ad:=TRUE;
+ELIF pos(in,"CNC") > 0 THEN out(printer,"D4");ad:=TRUE;
+ELIF pos(in,"CZ") > 0 THEN out(printer,"CC");ad:=TRUE;
+ELIF pos(in,"CNZ") > 0 THEN out(printer,"C4");ad:=TRUE;
+ELIF pos(in,"CM") > 0 THEN out(printer,"FC");ad:=TRUE;
+ELIF compress(in)="CP" THEN out(printer,"F4");ad:=TRUE;
+ELIF pos(in,"CPE") > 0 THEN out(printer,"EC");ad:=TRUE;
+ELIF pos(in,"CPO") > 0 THEN out(printer,"E4");ad:=TRUE;
+ELIF pos(in,"RET") > 0 THEN out(printer,"C9");
+ELIF pos(in,"RC") > 0 THEN out(printer,"D8");
+ELIF pos(in,"RNC") > 0 THEN out(printer,"D0");
+ELIF pos(in,"RZ") > 0 THEN out(printer,"C8");
+ELIF pos(in,"RNZ") > 0 THEN out(printer,"C0");
+ELIF pos(in,"RM") > 0 THEN out(printer,"F8");
+ELIF compress(in)="RP" THEN out(printer,"F0");
+ELIF pos(in,"RPE") > 0 THEN out(printer,"E8");
+ELIF pos(in,"RPO") > 0 THEN out(printer,"E0");
+ELIF pos(in,"RST") > 0 AND pos(in,"0") > 3 THEN out(printer,"C7");
+ELIF pos(in,"RST") > 0 AND pos(in,"1") > 3 THEN out(printer,"CF");
+ELIF pos(in,"RST") > 0 AND pos(in,"2") > 3 THEN out(printer,"D7");
+ELIF pos(in,"RST") > 0 AND pos(in,"3") > 3 THEN out(printer,"DF");
+ELIF pos(in,"RST") > 0 AND pos(in,"4") > 3 THEN out(printer,"E7");
+ELIF pos(in,"RST") > 0 AND pos(in,"5") > 3 THEN out(printer,"EF");
+ELIF pos(in,"RST") > 0 AND pos(in,"6") > 3 THEN out(printer,"F7");
+ELIF pos(in,"RST") > 0 AND pos(in,"7") > 3 THEN out(printer,"FF");
+ELIF pos(in,"MOV") > 0 THEN
+ IF pos(in,"A") = (pos(in,",")-1) THEN out(printer,"7");regh;
+ ELIF pos(in,"B") = (pos(in,",")-1) THEN out(printer,"4");regl;
+ ELIF pos(in,"C") = (pos(in,",")-1) THEN out(printer,"4");regh;
+ ELIF pos(in,"D") = (pos(in,",")-1) THEN out(printer,"5");regl;
+ ELIF pos(in,"E") = (pos(in,",")-1) THEN out(printer,"5");regh;
+ ELIF pos(in,"H") = (pos(in,",")-1) THEN out(printer,"6");regl;
+ ELIF pos(in,"L") = (pos(in,",")-1) THEN out(printer,"6");regh;
+ ELIF pos(in,"M",4) = (pos(in,",")-1) OR pos(in,"m") = (pos(in,",")-1)
+ THEN out(printer,"4");regl FI;
+ELIF pos(in,"MVI") > 0 THEN
+ IF pos(in,"A") = (pos(in,",")-1) THEN out(printer,"3E");
+ ELIF pos(in,"B") = (pos(in,",")-1) THEN out(printer,"06");
+ ELIF pos(in,"C") = (pos(in,",")-1) THEN out(printer,"0E");
+ ELIF pos(in,"D") = (pos(in,",")-1) THEN out(printer,"16");
+ ELIF pos(in,"E") = (pos(in,",")-1) THEN out(printer,"1E");
+ ELIF pos(in,"H") = (pos(in,",")-1) THEN out(printer,"26");
+ ELIF pos(in,"L") = (pos(in,",")-1) THEN out(printer,"2E");
+ ELIF pos(in,"M",4) = (pos(in,",")-1) OR pos(in,"m") = (pos(in,",")-1)
+ THEN out(printer,"36") FI;
+ELIF pos(in,"LXI") > 0 THEN ad:=TRUE;
+ IF pos(in,"B") > 4 THEN out(printer,"01");ad:=TRUE;
+ ELIF pos(in,"D") > 4 THEN out(printer,"11");ad:=TRUE;
+ ELIF pos(in,"H") > 4 THEN out(printer,"21");ad:=TRUE;
+ ELIF pos(in,"SP")> 4 THEN out(printer,"31");ad:=TRUE FI;
+ELIF pos(in,"PUSH") > 0 THEN
+ IF pos(in,"B") > 4 THEN out(printer,"C5");
+ ELIF pos(in,"D") > 4 THEN out(printer,"D5");
+ ELIF pos(in,"H",5) > 4 THEN out(printer,"E5");
+ ELIF pos(in,"A") > 4 OR pos(in,"PSW")> 4 THEN out(printer,"F5") FI;
+ ELIF pos(in,"POP") > 0 THEN
+ IF pos(in,"B") > 4 THEN out(printer,"C1");
+ ELIF pos(in,"D") > 4 THEN out(printer,"D1");
+ ELIF pos(in,"H") > 4 THEN out(printer,"E1");
+ ELIF pos(in,"A") > 4 OR pos(in,"PSW")> 4 THEN out(printer,"F1") FI;
+ELIF pos(in,"LDAX") > 0 THEN
+ IF pos(in,"B") > 4 THEN out(printer,"0A");
+ ELIF pos(in,"D",5) > 4 THEN out(printer,"1A") FI;
+ELIF pos(in,"STAX") > 0 THEN
+ IF pos(in,"B") > 4 THEN out(printer,"02");
+ ELIF pos(in,"D") > 4 THEN out(printer,"12") FI;
+ELIF pos(in,"INX") > 0 THEN
+ IF pos(in,"B") > 4 THEN out(printer,"03");
+ ELIF pos(in,"D") > 4 THEN out(printer,"13");
+ ELIF pos(in,"H") > 4 THEN out(printer,"2A");
+ ELIF pos(in,"SP")> 4 THEN out(printer,"3A") FI;
+ELIF pos(in,"DCX") > 0 THEN
+ IF pos(in,"B") > 4 THEN out(printer,"0B");
+ ELIF pos(in,"D",4)>4 THEN out(printer,"1B");
+ ELIF pos(in,"H") > 4 THEN out(printer,"2B");
+ ELIF pos(in,"SP")> 4 THEN out(printer,"3B") FI;
+ELIF pos(in,"DAD") > 0 THEN
+ IF pos(in,"B") > 4 THEN out(printer,"09");
+ ELIF pos(in,"D",4)>4 THEN out(printer,"19");
+ ELIF pos(in,"H") > 4 THEN out(printer,"29");
+ ELIF pos(in,"SP")> 4 THEN out(printer,"39") FI;
+ELIF pos(in,"ADD") > 0 THEN out(printer,"8");regl;
+ELIF pos(in,"ADC") > 0 THEN out(printer,"8");regl;
+ELIF pos(in,"SUB") > 0 THEN out(printer,"9");regl;
+ELIF pos(in,"SBB") > 0 THEN out(printer,"9");regl;
+ELIF pos(in,"ANA") > 0 THEN out(printer,"A");regl;
+ELIF pos(in,"XRA") > 0 THEN out(printer,"A");regl;
+ELIF pos(in,"ORA") > 0 THEN out(printer,"B");regl;
+ELIF pos(in,"CMP") > 0 THEN out(printer,"B");regl;
+ELIF pos(in,"INR") > 0 THEN
+ IFpos(in,"A") > 4 THEN out(printer,"3C") FI;
+ELIF pos(in,"INR") > 0 THEN
+ IFpos(in,"B") > 4 THEN out(printer,"04") FI;
+ELIF pos(in,"INR") > 0 THEN
+ IFpos(in,"C") > 4 THEN out(printer,"0C") FI;
+ELIF pos(in,"INR") > 0 THEN
+ IFpos(in,"D") > 4 THEN out(printer,"14") FI;
+ELIF pos(in,"INR") > 0 THEN
+ IFpos(in,"E") > 4 THEN out(printer,"1C") FI;
+ELIF pos(in,"INR") > 0 THEN
+ IFpos(in,"H") > 4 THEN out(printer,"24") FI;
+ELIF pos(in,"INR") > 0 THEN
+ IFpos(in,"L") > 4 THEN out(printer,"2C") FI;
+ELIF pos(in,"INR") > 0 THEN
+ IFpos(in,"M") > 4 OR pos(in,"m") > 4 THEN out(printer,"34") FI;
+ELIF pos(in, "IN") > 0 THEN out(printer,"DB"); number:=TRUE;
+ELIF pos(in,"DCR") > 0 THEN
+ IFpos(in,"A") > 4 THEN out(printer,"3D") FI;
+ELIF pos(in,"DCR") > 0 THEN
+ IFpos(in,"B") > 4 THEN out(printer,"05") FI;
+ELIF pos(in,"DCR") > 0 THEN
+ IFpos(in,"C",4) > 4 THEN out(printer,"0D") FI;
+ELIF pos(in,"DCR") > 0 THEN
+ IFpos(in,"D",4) > 4 THEN out(printer,"15") FI;
+ELIF pos(in,"DCR") > 0 THEN
+ IFpos(in,"E") > 4 THEN out(printer,"1D") FI;
+ELIF pos(in,"DCR") > 0 THEN
+ IFpos(in,"H") > 4 THEN out(printer,"25") FI;
+ELIF pos(in,"DCR") > 0 THEN
+ IFpos(in,"L") > 4 THEN out(printer,"2D") FI;
+ELIF pos(in,"DCR") > 0 THEN
+ IFpos(in,"M") > 4 OR pos(in,"m") > 4 THEN out(printer,"35") FI;
+ELIF pos(in,"ORG") > 0 THEN hilf:=compress(subtext(in,4,7));
+ putline(printer,hilf);
+ startaddresse:=hilf;
+ hexbeginn;
+ELIF pos(in,"TITL") > 0 THEN putline(printer,subtext(in,6));
+ELIF pos(in,"#") > 0 THEN hilf:=subtext(in,pos(in,"#")+1);
+ out(printer,hilf) ;
+ELSE putline("Fehler erkannt in Zeile "+text(fehler)+" bei '"+in+"' !");
+ out(printer,in);
+ putline(fehlerliste,"Fehler in Zeile "+text(fehler)+" bei: "+in);
+ count:=count+1;
+ falsch:=TRUE
+FI;
+line(printer);
+IF ad THEN ad:=FALSE;
+ fehler:=fehler+1;
+ out(printer,text(fehler,4));
+ cout(fehler);
+ out(printer," ");
+ hex;
+ out(printer," ");
+ IF pos(in,",") > 3 THEN hilf:=subtext(in,(pos(in,",")+1),(pos(in,",")+4));
+ fehler:=fehler+1;
+ out(printer,text(fehler,4));
+ cout(fehler);
+ out(printer," ");
+ hex;
+ out(printer," ");
+ line(printer)
+ ELSE hilf:=compress(subtext(in,10,15)) FI;
+ fehler:=fehler+1;
+ out(printer,text(fehler,4));
+ cout(fehler);
+ out(printer," ");
+ hex;
+ out(printer," ");
+ out(printer,subtext(hilf,3,4));
+ fehler:=fehler+1;
+ out(printer,text(fehler,4));
+ cout(fehler);
+ out(printer," ");
+ hex;
+ out(printer," ");
+ out(printer,subtext(hilf,1,2));
+ line(printer);
+
+ELIF number THEN number:=FALSE;
+ fehler:=fehler+1;
+ out(printer,text(fehler,4));
+ cout(fehler);
+ out(printer," ");
+ hex;
+ out(printer," ");
+ IF pos(in,",") > 2 THEN hilf:= subtext(in,
+ (pos(in,",") +1),(pos(in,",")+2));
+ out(printer,hilf);
+ line(printer)
+ ELSE out(printer,compress(subtext(in,14,21)));
+ line(printer) FI
+FI ;
+
+UNTIL compress(in) = "END" OR compress(in) = "end" OR eof(ass) ENDREPEAT;
+
+ IF count<> 0 THEN putline(text(count)+" Fehler erkannt.");
+ falsch:=TRUE
+ELSE putline(" Keine Fehler, "+text(fehler)+" Zeilen.") ;
+ falsch:=FALSE
+FI;
+putline(8*" "+7*"*"+" ENDE DER UEBERSETZUNG "+7*"*"+8*" ");
+pause(20);
+IF falsch THEN edit("errors","assemb") ELSE
+edit("maschinencode") FI;
+IF yes("Maschinencodelisting") THEN print("maschinencode") FI;
+IF yes("runagain") THEN runagain FI.
+
+hexbeginn:
+(*Hexadezimalzaehler*)
+INT VAR a1,a2,a3,a4,subi;
+TEXT VAR a1t,a2t,a3t,a4t,subt,counter;
+a1t:=subtext(startaddresse,1,1);
+a2t:=subtext(startaddresse,2,2);
+a3t:=subtext(startaddresse,3,3);
+a4t:=subtext(startaddresse,4,4).
+
+hex:
+subt:=a1t;
+decoder;
+a1:=subi;
+
+subt:=a2t;
+decoder;
+a2:=subi;
+
+subt:=a3t;
+decoder;
+a3:=subi;
+
+
+decoder;
+a4:=subi;
+
+zaehl;
+
+IF a4 = 16 THEN a4:=0;
+ a3:=a3+1 FI;
+
+IF a3 = 16 THEN a3:=0;
+ a2:=a2+1 FI;
+
+IF a2 = 16 THEN a2:=0;
+ a1:=a1+1 FI;
+
+IF a1 = 16 THEN a1:=0;
+ put(printer,"Storageoverflow !") FI;
+
+subi:=a1;
+encode;
+a1t:=subt;
+
+subi:=a2;
+encode;
+a2t:=subt;
+
+subi:=a3;
+encode;
+a3t:=subt;
+
+subi:=a4;
+encode;
+a4t:=subt;
+
+counter:=a1t;
+counter CAT a2t;
+counter CAT a3t;
+counter CAT a4t;
+put(printer,counter).
+
+zaehl:
+a4:=a4+1.
+
+decoder:
+IF subt ="A" THEN subi:=10;
+ELIF subt ="B" THEN subi:=11;
+ELIF subt ="C" THEN subi:=12;
+ELIF subt ="D" THEN subi:=13;
+ELIF subt ="E" THEN subi:=14;
+ELIF subt ="F" THEN subi:=15
+ELSE subi:=int(subt) FI.
+
+encode:
+IF subi = 10 THEN subt:="A";
+ELIF subi = 11 THEN subt:="B";
+ELIF subi = 12 THEN subt:="C";
+ELIF subi = 13 THEN subt:="D";
+ELIF subi = 14 THEN subt:="E";
+ELIF subi = 15 THEN subt:="F"
+ELSE subt:=text(subi) FI.
diff --git a/devel/misc/unknown/src/COPYDS.ELA b/devel/misc/unknown/src/COPYDS.ELA new file mode 100644 index 0000000..c0bd83c --- /dev/null +++ b/devel/misc/unknown/src/COPYDS.ELA @@ -0,0 +1,294 @@ +LET systemanker = 2 , (* Wird bei 'blockin' durch 2 geteilt *)
+ channel field = 4 ,
+ hg channel = 0 ;
+
+ROW 256 INT VAR block ;
+INT VAR return ;
+
+PROC pcb (TASK CONST id, INT CONST field, value) :
+ EXTERNAL 105
+ENDPROC pcb ;
+
+PROC copy ds (INT CONST task nr, ds nr, TEXT CONST destination) :
+ DATASPACE VAR ds ;
+ ROW 8 INT VAR dr eintrag ;
+ INT VAR old channel := channel, link, i, seite ;
+
+ system channel ;
+ zugriff ueber drdr ;
+ IF ist nilspace
+ THEN ds := nilspace
+ ELIF ist kleindatenraum
+ THEN lese kleindatenraum
+ ELSE lese grossdatenraum
+ FI ;
+ user channel ;
+ forget (destination, quiet) ;
+ copy (ds, destination) ;
+ forget (ds) .
+
+user channel :
+ disablestop ;
+ continue (old channel) ;
+ IF iserror
+ THEN forget (ds) ;
+ FI ;
+ enablestop .
+
+system channel :
+ break (quiet) ; (* Offiziell abmelden *)
+ pcb (myself, channel field, hg channel) . (* Inoffiziell anmelden *)
+
+zugriff ueber drdr :
+ systemanker lesen ;
+ drdr taskwurzel lesen ;
+ drdr dataspacewurzel lesen .
+
+erste seite im dreintrag :
+ link := 8 * (dsnr MOD 32) + 1 ;
+ FOR i FROM link UPTO link + 7 REP
+ IF block (i) <> -1
+ THEN LEAVE erste seite im dreintrag WITH i
+ FI
+ PER ;
+ user channel ;
+ errorstop ("Der Datenraum existiert nicht (DR-Eintrag = 8 mal FFFF)") ; 0 .
+
+ist nilspace :
+ block (erste seite im dreintrag) = -255 .
+
+ist kleindatenraum :
+ block (link) > -255 AND block (link) < 0 .
+
+lese kleindatenraum :
+ ds := nilspace ;
+ IF seite eins existiert
+ THEN blockin (ds, 1, block (link + 1)) ;
+ IF return <> 0
+ THEN user channel ;
+ putline ("Warnung: Seite 1 des Datenraums nicht lesbar: " +
+ text (return)) ;
+ system channel
+ FI
+ FI ;
+ IF seite zwei existiert
+ THEN blockin (ds, 2, block (link + 2)) ;
+ IF return <> 0
+ THEN user channel ;
+ putline ("Warnung: Seite 2 des Datenraums nicht lesbar: " +
+ text (return)) ;
+ system channel
+ FI
+ FI ;
+ IF mehr als zwei seiten
+ THEN FOR i FROM 0 UPTO 4 REP
+ IF hoehere seite existiert
+ THEN blockin (ds, i + basisseite, block (link + i + 3)) ;
+ IF return <> 0
+ THEN user channel ;
+ putline ("Warnung: Seite " + text (i + basisseite)
+ + " des Datenraums nicht lesbar: "
+ + text (return)) ;
+ system channel
+ FI
+ FI
+ PER
+ FI .
+
+seite eins existiert :
+ exists (block (link + 1)) .
+
+seite zwei existiert :
+ exists (block (link + 2)) .
+
+mehr als zwei seiten :
+ exists (block (link)) .
+
+hoehere seite existiert :
+ exists (block (link + i + 3)) .
+
+basisseite :
+ block (link) AND 255 .
+
+lese grossdatenraum :
+ ds := nilspace ;
+ dreintrag kopieren ;
+ seite := 0 ;
+ FOR i FROM 1 UPTO 8 REP
+ IF seitenblocktabelle existiert
+ THEN seitenblocktabelle lesen ;
+ seiten kopieren wenn sie in der seitenblocktabelle vorhanden sind
+ ELSE seite INCR 256
+ FI
+ PER .
+
+seitenblocktabelle lesen :
+ blockin (dr eintrag (i)) ;
+ IF return <> 0
+ THEN user channel ;
+ putline ("Warnung: Seitenblocktabelle " + text (i-1) +
+ " des Datenraums nicht lesbar: " + text (return)) ;
+ putline ("Damit fehlen die Seiten " + text (max (1, seite)) +
+ " bis " + text (seite + 255)) ;
+ system channel
+ FI .
+
+seiten kopieren wenn sie in der seitenblocktabelle vorhanden sind :
+ FOR link FROM 1 UPTO 256 REP
+ IF seite vorhanden
+ THEN blockin (ds, seite, block (link)) ;
+ IF return <> 0
+ THEN user channel ;
+ putline ("Warnung: Seite " + text (seite) +
+ " des Datenraums nicht lesbar: " + text (return)) ;
+ system channel
+ FI ;
+ user channel ;
+ cout (seite) ;
+ system channel
+ FI ;
+ seite INCR 1
+ PER .
+
+seite vorhanden :
+ exists (block (link)) .
+
+seitenblocktabelle existiert :
+ exists (dreintrag (i)) .
+
+dreintrag kopieren :
+ FOR i FROM 0 UPTO 7 REP
+ dreintrag (i + 1) := block (link + i)
+ PER .
+
+systemanker lesen :
+ blockin (systemanker) ;
+ IF return <> 0
+ THEN user channel ;
+ errorstop ("Systemanker nicht lesbar: " + text (return))
+ FI .
+
+drdr taskwurzel lesen :
+ link := block (tasknr DIV 32 + 1) ;
+ IF link = -1
+ THEN user channel ;
+ errorstop ("Die Task existiert nicht")
+ FI ;
+ blockin (link) ;
+ IF return <> 0
+ THEN user channel ;
+ errorstop ("Taskwurzel des DRDR nicht lesbar: " + text (return))
+ FI .
+
+drdr dataspacewurzel lesen :
+ link := block (8 * (tasknr MOD 32) + dsnr DIV 32 + 1) ;
+ IF NOT exists (link)
+ THEN user channel ;
+ errorstop ("Der Datenraum (und weitere 31) existiert nicht")
+ FI ;
+ blockin (link) ;
+ IF return <> 0
+ THEN user channel ;
+ errorstop ("Dataspacewurzel des DRDR nicht lesbar: " +
+ text (return))
+ FI .
+
+ENDPROC copy ds ;
+
+BOOL PROC exists (INT CONST blocknr) :
+ blocknr <> -1 AND blocknr <> -255
+ENDPROC exists ;
+
+PROC blockin (INT CONST blocknr) :
+ blockin (block, 0, blocknr DIV 2, return) ; (* ggf COPBIT ausblenden *)
+ENDPROC blockin ;
+
+PROC blockin (DATASPACE VAR ds, INT CONST page, blocknr) :
+ blockin (ds, page, 0, blocknr DIV 2, return) (* ggf COPBIT ausblenden *)
+ENDPROC blockin ;
+
+PROC dump (TEXT CONST datei) :
+ edit dump (datei, FALSE)
+ENDPROC dump ;
+
+PROC edit dump (TEXT CONST datei, BOOL CONST write access) :
+ BOUND STRUCT (ROW 252 INT page1, ROW 2047 ROW 256 INT blocks) VAR b ;
+ b := old (datei) ;
+ INT VAR blocknr := 1, i ;
+ TEXT VAR esc char, t ;
+ BOOL VAR clear := TRUE , modified ;
+ ROW 256 INT VAR page 1 ;
+ page 1 (1) := 0 ;
+ page 1 (2) := 0 ;
+ page 1 (3) := type (old (datei)) ;
+ page 1 (4) := -1 ;
+ page ;
+ put ("Info mit 'ESC ?'") ;
+ dump cursor (4, 3) ;
+ REP
+ out (""1""5"Datei: """) ; out (datei) ; put ("""") ;
+ put (", Page:") ; put (text (blocknr, 5)) ;
+ put (", Dspages:") ; put (text (dspages (old (datei)), 5)) ;
+ put (", Type:") ; put (type (old (datei))) ;
+ IF blocknr = 1
+ THEN FOR i FROM 1 UPTO 252 REP
+ page1 (i + 4) := b.page1 (i)
+ PER ;
+ edit dump (page 1, 1, 256, clear, write access, modified, esc char);
+ IF modified
+ THEN FOR i FROM 1 UPTO 252 REP
+ b.page1 (i) := page 1 (i + 4)
+ PER ;
+ type (old (datei), page 1 (3))
+ FI
+ ELSE edit dump (b.blocks (blocknr), 1, 256, clear, write access, modified, esc char)
+ FI ;
+ clear := TRUE ;
+ IF esc char = ""1""10""
+ THEN blocknr INCR 1
+ ELIF esc char = ""1""3""
+ THEN IF blocknr > 1
+ THEN blocknr DECR 1
+ ELSE clear := FALSE ;
+ out (""1""15"E r s t e S e i t e "14""5"")
+ FI
+ ELIF esc char = ""27"q"
+ THEN LEAVE edit dump
+ ELIF esc char = ""27"?"
+ THEN clear := FALSE ;
+ putline (""1"ESC:?,p,q,w,F,0; HOP:HOP,LEFT,UP,DOWN,RIGHT; DEL,INS,LEFT,UP,RIGHT") ;
+ ELIF esc char = ""27"p"
+ THEN REP
+ put(""1""5"Neue Pagenr:") ;
+ t := text (blocknr) ;
+ editget (t) ;
+ blocknr := int (t)
+ UNTIL blocknr >= 0 AND blocknr < 2048 PER
+ ELSE clear := FALSE
+ FI ;
+ PER
+ENDPROC edit dump ;
+
+INT VAR task index, ds nr ;
+TEXT VAR task id ;
+page ;
+put ("""Taskname"" oder Taskindex:") ;
+getline (task id) ;
+IF pos (task id, """") > 0
+ THEN scan (task id) ;
+ nextsymbol (task id) ;
+ task index := index (task (task id))
+ ELSE task index := int (task id)
+FI ;
+put ("Dataspacenummer in der Task:") ;
+get (ds nr) ;
+IF ds nr < 4
+ THEN errorstop ("Es gibt nur DATASPACE-Nummern >= 4")
+FI ;
+IF yes ("Soll vorher ein Fixpoint gesetzt werden")
+ THEN fixpoint
+FI ;
+forget ("new ds", quiet) ;
+copy ds (task index, ds nr, "new ds") ;
+putline ("Der kopierte Datenraum steht in der Datei ""new ds""") ;
+dump ("new ds")
diff --git a/devel/misc/unknown/src/DS4.ELA b/devel/misc/unknown/src/DS4.ELA new file mode 100644 index 0000000..6ebcf2d --- /dev/null +++ b/devel/misc/unknown/src/DS4.ELA @@ -0,0 +1,268 @@ +PACKET ds 4 access DEFINES ds 4 :
+
+PROC ds 4 :
+ INT VAR segment, block nr , i , adr , byte ;
+ TEXT VAR key , eingabe ;
+ BOOL VAR new headline ;
+ page ;
+ put ("Segment:") ;
+ get (segment) ;
+ ROW 256 INT VAR space ;
+ block nr := 0 ;
+ new headline := FALSE ;
+ REP
+ IF new headline THEN out (""1""5"")
+ ELSE page
+ FI ;
+ put (" Segment:") ; put (text(segment,5)) ; (* Cursor 1-16 *)
+ put (", Block:") ; put (text(block nr,5)) ; (* Cursor 17-31 *)
+ put (", Wortaddr:") ; out (hex8 (segment)) ;
+ put (text(hex16((""0""+code(blocknr))ISUB1),5)) ;
+ put ("Wahl : + - e s b w a h d o") ; (* ^ Cursor 32 - 51 *)
+ IF NOT new headline THEN
+ line ; (* ^ 52 - 77 *)
+ adr := (""0"" + code (block nr)) ISUB 1 ;
+ FOR i FROM 0 UPTO 255 REP
+ space (i+1) := get word (segment, i + adr)
+ PER ;
+ dump (space)
+ FI ;
+ out (""1"") ;
+ new headline := FALSE ;
+ inchar (key) ;
+ out (key) ;
+ IF key = "+" THEN IF block nr = 255
+ THEN block nr := 0 ;
+ segment INCR 1
+ ELSE block nr INCR 1
+ FI
+ ELIF key = "-" THEN IF block nr = 0 AND segment > 0
+ THEN block nr := 255 ;
+ segment DECR 1
+ ELIF block nr > 0 THEN block nr DECR 1
+ FI
+ ELIF key = "s" THEN cursor (11,1) ;
+ eingabe := text (segment) ;
+ editget (eingabe, 1000, 5) ;
+ segment := int (eingabe)
+ ELIF key = "b" THEN cursor (26,1) ;
+ eingabe := hex8 (block nr) ;
+ editget (eingabe, 1000, 5) ;
+ block nr := integer (eingabe)
+ ELIF key = "w" THEN cursor (44,1) ;
+ eingabe := hex16 (adr) ;
+ edit get (eingabe, 1000, 5) ;
+ adr := integer (eingabe) ;
+ eingabe := hex16 (get word (segment, adr)) ;
+ cursor (32,1) ;
+ put (",NeuesWort:") ;
+ editget (eingabe, 1000,5) ;
+ put word (segment, adr, integer (eingabe)) ;
+ ELIF key = "d" THEN cursor (32,1) ;
+ new headline := TRUE ;
+ put (", Dez->Hex:") ;
+ REAL VAR r ;
+ get (r) ;
+ cursor (32,1) ;
+ put (", - Taste - Hex:") ;
+ IF r < 256.0 AND r >= 0.0 THEN put (hex8 (int(r)))
+ ELIF r < 0.0 THEN put (hex16 (int (r)))
+ ELIF r < 32768.0 THEN put (hex16 (int(r)))
+ ELSE put (hex16 (int (r - 65536.0)))
+ FI ; pause
+ ELIF key = "h" THEN cursor (32,1) ;
+ new headline := TRUE ;
+ put (", Hex->Dez:") ;
+ getline (eingabe) ;
+ cursor (32,1) ;
+ put (", - Taste - Dez:") ;
+ put (integer (eingabe)) ;
+ IF integer (eingabe) < 0 THEN put (", Positiv:") ;
+ put (positiv (eingabe))
+ FI ; pause
+ ELIF key = "a" THEN cursor (32,1) ;
+ new headline := TRUE ;
+ put (", ASCII->Hex (Taste)"5"") ;
+ inchar (eingabe) ;
+ put (" = ") ; put (hex8 (code (eingabe))) ;
+ put ("- Taste -") ;
+ pause
+ ELIF key = "o" THEN cursor (32,1) ;
+ new headline := TRUE ;
+ put (", Hex->0Opcde:") ;
+ getline (eingabe) ;
+ cursor (32,1) ;
+ put (", - Taste - :") ;
+ put (eumel0 opcode (integer (eingabe))) ;
+ pause
+ FI ;
+ UNTIL key = "e" PER ;
+
+ENDPROC ds 4 ;
+
+PROC dump (ROW 256 INT CONST page) :
+ INT VAR i,j ,k ;
+ TEXT VAR t := " " ;
+ k := 1 ; j := 1 ;
+ put ("00:") ;
+ FOR i FROM 1 UPTO 256 WHILE incharety <> ""27""REP
+ put hex16 (page (i)) ;
+ replace (t, j, ascii (page (i))) ;
+ j := j + 2 ;
+ IF ((j-1) MOD 8) = 0 THEN out (" ") FI ;
+ IF k = 22 AND j = 9 THEN j := 25 ; 34 TIMESOUT " " FI ;
+ IF j = 25 THEN
+ out (" ") ; out (t) ;
+ replace (t, 1, " ") ;
+ IF k < 22 THEN
+ line ;
+ out(hex8 (i)); put (":")
+ FI ;
+ k := k + 1 ;
+ j := 1
+ FI ;
+PER ;
+ENDPROC dump ;
+
+
+TEXT PROC ascii (INT CONST wert) :
+ TEXT VAR t := " " ;
+ replace (t, 1, wert) ;
+ IF (t SUB 1) < " " OR (t SUB 1) > ""126"" THEN replace (t, 1, ".") FI ;
+ IF (t SUB 2) < " " OR (t SUB 2) > ""126"" THEN replace (t, 2, ".") FI ;
+ t
+ENDPROC ascii ;
+
+PROC put hex16 (INT CONST wert) :
+ TEXT VAR t := " " ;
+ replace (t, 1, wert) ;
+ out hex digit (code (t SUB 1) DIV 16) ;
+ out hex digit (code (t SUB 1) AND 15) ;
+ out hex digit (code (t SUB 2) DIV 16) ;
+ out hex digit (code (t SUB 2) AND 15) ;
+ENDPROC put hex16 ;
+
+PROC out hex9 (INT CONST wert) :
+ out hex digit (wert DIV 256) ;
+ out hex digit (wert DIV 16 AND 15) ;
+ out hex digit (wert AND 15)
+ENDPROC out hex9 ;
+
+TEXT PROC hex8 (INT CONST wert) :
+ hex digit (wert DIV 16) +
+ hex digit (wert AND 15)
+ENDPROC hex8 ;
+
+TEXT PROC hex16 (INT CONST wert) :
+ TEXT VAR t := " " ;
+ replace (t, 1, wert) ;
+ hex digit (code (t SUB 2) DIV 16) +
+ hex digit (code (t SUB 2) AND 15) +
+ hex digit (code (t SUB 1) DIV 16) +
+ hex digit (code (t SUB 1) AND 15)
+ENDPROC hex16 ;
+
+TEXT PROC hex digit (INT CONST wert) :
+ IF wert < 10 THEN code (wert + 48)
+ ELSE code (wert + 55)
+ FI
+ENDPROC hex digit ;
+
+PROC out hex digit (INT CONST wert) :
+ IF wert < 10 THEN out (code (wert + 48))
+ ELSE out (code (wert + 55))
+ FI
+ENDPROC out hex digit ;
+
+INT PROC integer (TEXT CONST hex addr) :
+ INT VAR i ;
+ REAL VAR summe := 0.0 ;
+ FOR i FROM 1 UPTO length (hex addr) REP
+ summe := summe * 16.0 ;
+ summe INCR real (digit)
+ PER ;
+ IF summe > 32767.0 THEN int (summe - 65536.0)
+ ELSE int (summe)
+ FI.
+
+digit :
+ TEXT CONST char := hex addr SUB i ;
+ IF char >= "a" THEN code (char) - 87
+ ELIF char >= "A" THEN code (char) - 55
+ ELSE code (char) - 48
+ FI
+ENDPROC integer ;
+
+REAL PROC positiv (TEXT CONST wert) :
+ INT VAR i ;
+ REAL VAR summe := 0.0 ;
+ FOR i FROM 1 UPTO length (wert) REP
+ summe := summe * 16.0 ;
+ summe INCR real (digit)
+ PER ;
+ summe .
+
+digit :
+ TEXT CONST char := wert SUB i ;
+ IF char >= "a" THEN code (char) - 87
+ ELIF char >= "A" THEN code (char) - 55
+ ELSE code (char) - 48
+ FI
+ENDPROC positiv ;
+
+TEXT PROC eumel0 opcode (INT CONST word) :
+ INT VAR op1 := (word AND 31744) DIV 1024 ,
+ op2 := (word AND 768) DIV 128 ,
+ low := word AND 255 ,
+ long data := (word AND 768) * 2 + (word AND 255) ;
+ IF word < 0 THEN op2 INCR 1 ; long data INCR 256 FI ;
+ SELECT op1 OF
+ CASE 0 : "LN " + text (low)
+ CASE 1 : "LN " + text (long data)
+ CASE 2 : "MOV "
+ CASE 3 : "INC1 "
+ CASE 4 : "DEC1 "
+ CASE 5 : "INC "
+ CASE 6 : "DEC "
+ CASE 7 : "ADD "
+ CASE 8 : "SUB "
+ CASE 9 : "CLEAR "
+ CASE 10 : "TEST "
+ CASE 11 : "EQU "
+ CASE 12 : "LSEQ "
+ CASE 13 : "FMOV "
+ CASE 14 : "FADD "
+ CASE 15 : "FSUB "
+ CASE 16 : "FMULT "
+ CASE 17 : "FDIV "
+ CASE 18 : "FLSEQ "
+ CASE 19 : "TMOV "
+ CASE 20 : "TEQU "
+ CASE 21 : "LSEQU "
+ CASE 22 : "ACCDS "
+ CASE 23 : "REF "
+ CASE 24 : "SUBS "
+ CASE 25 : "SEL "
+ CASE 26 : "PPV "
+ CASE 27 : "PP "
+ CASE 28 : "BR " + hex8 (low)
+ CASE 29 : "BR " + hex16 (long data)
+ CASE 30 : "CALL "
+ OTHERWISE op 31
+ ENDSELECT.
+
+op31 :
+SELECT op 2 OF
+ CASE 0 : "IS """ + code (low) + """"
+ CASE 1 : "STIM " + hex8 (low)
+ CASE 2 : "MOVX "
+ CASE 3 : "PW "
+ CASE 4 : "GW "
+ CASE 5 : "PENTER " + hex8 (low)
+ CASE 6 : "ESC " + text (low)
+ CASE 7 : "LONGA " + eumel 0 opcode ((low AND 124) * 256)
+ OTHERWISE "?????"
+ENDSELECT
+ENDPROC eumel 0 opcode
+
+ENDPACKET ds 4 access
diff --git a/devel/misc/unknown/src/PRIVS.ELA b/devel/misc/unknown/src/PRIVS.ELA new file mode 100644 index 0000000..dfed695 --- /dev/null +++ b/devel/misc/unknown/src/PRIVS.ELA @@ -0,0 +1,485 @@ +PACKET privs DEFINES pcb,
+ pages,
+ internal pause,
+ set error stop,
+ sld,
+ next active task index,
+ create process,
+ sysgen off,
+ (* cdb int ,
+ cdb text , *)
+ block,
+ unblock,
+ sys op,
+ set clock,
+ fixpoint,
+ save system,
+ internal shutup,
+ collect garbage blocks,
+ send,
+ define collector,
+ erase process,
+ halt process ,
+
+ return false ,
+ return true ,
+ term ,
+ char read ,
+ begin char read ,
+ char write ,
+ end char write ,
+ get char ,
+ find non blank ,
+ div rem 256 ,
+ add mul 256 ,
+ is digit ,
+ is lowercase or digit ,
+ is lowercase ,
+ is uppercase ,
+ gen addr ,
+ gen code addr ,
+ is short address,
+ sysgen ,
+ get tables ,
+ put tables ,
+ erase tables ,
+ exec ,
+ (* pproc ,
+ pcall , *)
+ case ,
+ move ,
+ address ,
+ alias ,
+ IMULT ,
+ arith 15 ,
+ arith 16 ,
+ put word ,
+ get word :
+
+
+PROC pcb (TASK CONST id, INT CONST field, value) :
+
+ EXTERNAL 105
+
+ENDPROC pcb ;
+
+
+PROC pages (DATASPACE CONST ds, TASK CONST id) :
+
+ EXTERNAL 88
+
+ENDPROC pages ;
+
+
+PROC internal pause (INT CONST time limit) :
+
+ EXTERNAL 66
+
+ENDPROC internal pause ;
+
+
+PROC set error stop (INT CONST code) :
+
+ EXTERNAL 77
+
+ENDPROC set error stop ;
+
+
+PROC sld (INT CONST in, REAL VAR real, INT VAR out) :
+
+ EXTERNAL 96
+
+ENDPROC sld ;
+
+
+PROC next active task index (TASK VAR id) :
+
+ EXTERNAL 118
+
+ENDPROC next active task index ;
+
+
+PROC create process (TASK CONST id, PROC start) :
+
+ create (id, PROC start)
+
+ENDPROC create process ;
+
+
+PROC create (TASK CONST id, PROC start) :
+
+ EXTERNAL 111
+
+ENDPROC create ;
+
+
+PROC sysgen off :
+
+ INT VAR x := 0 ;
+ elan (3, x,x,x,x,x,x,x,x,x,x,x)
+
+ENDPROC sysgen off ;
+
+
+PROC elan (INT CONST mode, INT VAR a,b,c,d,e,f,g,h,i,j,k) :
+
+ EXTERNAL 256
+
+ENDPROC elan ;
+
+
+INT PROC cdbint (INT CONST adr) :
+
+ EXTERNAL 116
+
+ENDPROC cdbint ;
+
+
+TEXT PROC cdbtext (INT CONST adr) :
+
+ EXTERNAL 117
+
+ENDPROC cdbtext ;
+
+
+PROC block (TASK CONST id) :
+
+ EXTERNAL 109
+
+ENDPROC block ;
+
+
+PROC unblock (TASK CONST id) :
+
+ EXTERNAL 108
+
+ENDPROC unblock ;
+
+
+PROC sys op (INT CONST function) :
+
+ EXTERNAL 90
+
+ENDPROC sys op ;
+
+
+PROC set clock (TASK CONST id, REAL CONST value) :
+
+ EXTERNAL 82
+
+ENDPROC set clock ;
+
+
+PROC set clock (REAL CONST value) :
+
+ EXTERNAL 103
+
+ENDPROC set clock ;
+
+
+PROC fixpoint :
+
+ sys op (2)
+
+ENDPROC fixpoint ;
+
+
+PROC collect garbage blocks :
+
+ sys op (1)
+
+ENDPROC collect garbage blocks ;
+
+
+PROC internal shutup :
+
+ sys op (4)
+
+ENDPROC internal shutup ;
+
+
+PROC save system :
+
+ sys op (12)
+
+ENDPROC save system ;
+
+
+PROC send (TASK CONST from, to, INT CONST order, DATASPACE VAR ds,
+ INT VAR receipt) :
+
+ EXTERNAL 127
+
+ENDPROC send ;
+
+
+PROC define collector (TASK CONST task) :
+
+ EXTERNAL 128
+
+ENDPROC define collector ;
+
+
+PROC erase process (TASK CONST id) :
+
+ EXTERNAL 112
+
+ENDPROC erase process ;
+
+
+PROC halt process (TASK CONST id) :
+
+ EXTERNAL 110
+
+ENDPROC halt process ;
+
+
+(****************************** undokumentiert **************************)
+
+
+BOOL PROC return false :
+
+ EXTERNAL 1
+
+ENDPROC return false ;
+
+
+BOOL PROC return true :
+
+ EXTERNAL 2
+
+ENDPROC return true ;
+
+
+PROC term :
+
+ EXTERNAL 4
+
+ENDPROC term ;
+
+
+PROC char read (INT CONST pos) :
+
+ EXTERNAL 8
+
+ENDPROC char read ;
+
+
+INT PROC begin char read (INT VAR pos) :
+
+ EXTERNAL 9
+
+ENDPROC begin char read ;
+
+
+PROC char write (INT VAR next, INT CONST char, int) :
+
+ EXTERNAL 10
+
+ENDPROC char write ;
+
+
+PROC end char write (INT VAR a, b, INT CONST char) :
+
+ EXTERNAL 11
+
+ENDPROC end char write ;
+
+
+PROC ctt (INT CONST adr, INT VAR result) :
+
+ EXTERNAL 12
+
+ENDPROC ctt ;
+
+
+BOOL PROC get char (TEXT CONST text, INT VAR pos, char) :
+
+ EXTERNAL 13
+
+ENDPROC get char ;
+
+
+BOOL PROC find non blank (INT VAR non blank char, TEXT CONST string,
+ INT VAR pos) :
+
+ EXTERNAL 14
+
+ENDPROC find non blank ;
+
+
+PROC divrem 256 (INT VAR a, b) :
+
+ EXTERNAL 15
+
+ENDPROC divrem 256 ;
+
+
+PROC addmul 256 (INT VAR a, b) :
+
+ EXTERNAL 16
+
+ENDPROC addmul 256 ;
+
+
+BOOL PROC is digit (INT CONST char) :
+
+ EXTERNAL 18
+
+ENDPROC is digit ;
+
+
+BOOL PROC is lowercase or digit (INT CONST char) :
+
+ EXTERNAL 19
+
+ENDPROC is lowercase or digit ;
+
+
+BOOL PROC is lowercase (INT CONST char) :
+
+ EXTERNAL 20
+
+ENDPROC is lowercase ;
+
+
+BOOL PROC is uppercase (INT CONST char) :
+
+ EXTERNAL 21
+
+ENDPROC is uppercase ;
+
+
+PROC gen addr (INT CONST word1, word2, INT VAR result) :
+
+ EXTERNAL 22
+
+ENDPROC gen addr ;
+
+
+BOOL PROC gen code addr (INT CONST word1, word2, INT VAR result) :
+
+ EXTERNAL 23
+
+ENDPROC gen code addr ;
+
+
+BOOL PROC is short address (INT CONST address) :
+
+ EXTERNAL 24
+
+ENDPROC is short address ;
+
+
+PROC sysgen :
+
+ EXTERNAL 25
+
+ENDPROC sysgen ;
+
+
+PROC get tables :
+
+ EXTERNAL 26
+
+ENDPROC get tables ;
+
+
+PROC put tables :
+
+ EXTERNAL 27
+
+ENDPROC put tables ;
+
+
+PROC erase tables :
+
+ EXTERNAL 28
+
+ENDPROC erase tables ;
+
+
+PROC exec (INT CONST module number) :
+
+ EXTERNAL 29
+
+ENDPROC exec ;
+
+(*
+PROC pproc (PROC proc) :
+
+ EXTERNAL 30
+
+ENDPROC pproc ;
+
+
+PROC pcall (PROC proc) :
+
+ EXTERNAL 31
+
+ENDPROC pcall ;
+*)
+
+BOOL PROC case (INT CONST switch, limit) :
+
+ EXTERNAL 32
+
+ENDPROC case ;
+
+
+PROC move (PROC len, INT VAR from area, to area) :
+
+ EXTERNAL 33
+
+ENDPROC move ;
+
+
+INT PROC alias (DATASPACE CONST ds, INT VAR result) :
+
+ EXTERNAL 34
+
+ENDPROC alias ;
+
+
+INT PROC address (INT CONST object) :
+
+ EXTERNAL 35
+
+ENDPROC address ;
+
+
+INT OP IMULT (INT CONST a, b) :
+
+ EXTERNAL 40
+
+ENDOP IMULT ;
+
+
+PROC arith 15 :
+
+ EXTERNAL 91
+
+ENDPROC arith 15 ;
+
+
+PROC arith 16 :
+
+ EXTERNAL 92
+
+ENDPROC arith 16 ;
+
+
+PROC put word (INT CONST segment, address, word) :
+
+ EXTERNAL 119
+
+ENDPROC put word ;
+
+
+INT PROC get word (INT CONST segment, address) :
+
+ EXTERNAL 120
+
+ENDPROC get word
+
+ENDPACKET privs
diff --git a/devel/misc/unknown/src/TABINFO.ELA b/devel/misc/unknown/src/TABINFO.ELA new file mode 100644 index 0000000..af419bb --- /dev/null +++ b/devel/misc/unknown/src/TABINFO.ELA @@ -0,0 +1,117 @@ +PACKET table info DEFINES table info : (* Michael Staubermann *)
+ (* 02.12.86 *)
+LET insert flag addr = 4654 ,
+
+(* prev modnr addr = 4662 , *)
+ cur modnr addr = 4806 ,
+
+ prev code end addr = 4775 ,
+ cur code end addr = 4807 ,
+
+ prev name tab end addr = 4688 ,
+ cur name tab end addr = 4693 ,
+
+ prev permanent tab end addr = 4704 ,
+ cur permanent tab end addr = 4707 ,
+
+ prev denoter end addr = 4815 ,
+ cur denoter end addr = 4809 ,
+
+ prev static data end addr = 4816 ,
+ cur static data end addr = 4810 ,
+ prev static data begin addr = 4817 ,
+ cur static data begin addr = 4811 ,
+(*
+ begin of hash table = 0 ,
+ end of hash table = 1023 ,
+
+ begin of string table = 1024 ,
+ end of string table = 4093 ,
+*)
+ begin of name table = 4096 ,
+ end of name table = 22783 ,
+
+ begin of permanent table = 22784 ,
+ end of permanent table = 32767 ,
+
+ begin of code = 4096 ,
+
+ begin of data = 4096 ;
+
+INT CONST end of code :: -1 ,
+ end of data :: -1 ;
+
+BOOL VAR was insert ;
+
+INT PROC getword (INT CONST segment, address) :
+ EXTERNAL 120
+ENDPROC getword ;
+
+PROC arith16 :
+ EXTERNAL 92
+ENDPROC arith16 ;
+
+INT OP SUB (INT CONST left, right) :
+ arith 16 ;
+ left - right
+ENDOP SUB ;
+
+PROC entry (TEXT CONST name, BOOL CONST size,
+ INT CONST begin, cur, prev, end) :
+ put (subtext (name + " ....................", 1, 20) + ":") ;
+ IF size
+ THEN put (card (end SUB begin)) ;
+ put (card (end SUB cur)) ;
+ put (card (cur SUB begin)) ;
+ put (card (int (positiv (cur SUB begin) /
+ positiv (end SUB begin) * 100.0))) ;
+ ELSE put (" ")
+ FI ;
+ IF NOT was insert
+ THEN put (card (prev - cur))
+ FI ;
+ line
+ENDPROC entry ;
+
+PROC table info :
+ was insert := getword (0, insert flag addr) = 0 ;
+ line ;
+ put ("N„chste Modulenr.:") ;
+ put (getword (0, cur modnr addr)) ; line (2) ;
+ put ("Name Size Free Used Used%") ;
+ IF NOT was insert
+ THEN put ("LastRun")
+ FI ;
+ line ;
+ entry ("Permanenttable", TRUE, begin of permanent table,
+ getword (0, cur permanent tab end addr),
+ getword (0, prev permanent tab end addr), end of permanent table) ;
+ entry ("Nametable", TRUE, begin of name table,
+ getword (0, cur name tab end addr),
+ getword (0, prev name tab end addr), end of name table) ;
+ entry ("Code", TRUE, begin of code,
+ getword (0, cur code end addr),
+ getword (0, prev code end addr), end of code) ;
+ entry ("Data", TRUE, begin of data,
+ getword (0, cur static data end addr),
+ getword (0, prev static data end addr), end of data) ;
+ line ;
+ENDPROC table info ;
+
+REAL PROC positiv (INT CONST value) :
+ IF value < 0
+ THEN real (value) + 65536.0
+ ELSE real (value)
+ FI
+ENDPROC positiv ;
+
+TEXT PROC card (INT CONST i) :
+ IF i = minint
+ THEN "32768"
+ ELIF i < 0
+ THEN subtext (text (real (i) + 65536.0), 1, 5)
+ ELSE text (i, 5)
+ FI
+ENDPROC card
+
+ENDPACKET table info ;
diff --git a/devel/misc/unknown/src/TRACE.ELA b/devel/misc/unknown/src/TRACE.ELA new file mode 100644 index 0000000..63c1455 --- /dev/null +++ b/devel/misc/unknown/src/TRACE.ELA @@ -0,0 +1,552 @@ +PACKET tracer DEFINES breakpoint handler , (* M. Staubermann *)
+ handlers module nr , (* 20.04.86 *)
+ list breakpoints ,
+ set breakpoint ,
+ reset breakpoint ,
+ source file ,
+ trace ,
+ reset breakpoints :
+
+LET local base field = 25 ,
+ packet data segment = 0 ,
+ local data segment = 1 ,
+
+ begin of module nr link table = 512 ,
+
+ previous local base offset = 0 ,
+ return address offset = 1 ,
+ return segment offset = 2 ,
+ c8k offset = 3 ,
+
+ opcode mask = 31744 ,
+ bt opcode = 0 ,
+ btlong opcode = 1024 ,
+ bf opcode = 28672 ,
+ bflong opcode = 29696 ,
+ br opcode = 28672 ,
+ brlong opcode = 29696 ,
+
+ ln opcode = 0 ,
+ ln long opcode = 1024 ,
+ call opcode = 30720 ,
+ pcall opcode = 32543 ;
+
+LET nr of breakpoints = 2 ,
+ BREAKPOINT = STRUCT (BOOL set,
+ INT segment,
+ address,
+ saved word) ;
+
+ROW nr of breakpoints BREAKPOINT VAR breakpoints ;
+BREAKPOINT CONST init breakpoint :: BREAKPOINT:(FALSE, 3, -5, 0) ;
+
+FOR i FROM 1 UPTO nr of breakpoints REP
+ breakpoints (i) := init breakpoint
+PER ;
+
+BOOL VAR auto trace := FALSE ,
+ zweizeilig ;
+INT VAR next instruction address ,
+ next instruction segment ,
+ next instruction ,
+ return segment,
+ return address,
+ breakpoint address ,
+ breakpoint segment ,
+ breakpoint nr ,
+ lbas ,
+ this local base ,
+ branch address ,
+ c8k ,
+ packet base ,
+ op word,
+ saved word ,
+ i, x, y ,
+ actual line number := -1 ,
+ handler module := 395 ; (* PROC stop *)
+
+TEXT VAR key := "" ,
+ previous key := "" ,
+ statement line := "" ,
+ source line := "" ,
+ source file name := "" ;
+
+FILE VAR source ;
+
+PROC trace (BOOL CONST b) :
+ auto trace := b
+ENDPROC trace ;
+
+PROC source file (TEXT CONST file name) :
+ IF exists (file name)
+ THEN source := sequentialfile (modify, file name)
+ FI ;
+ IF actual line number >= 0 CAND actual line number <= lines (source)
+ THEN toline (source, actual line number) ;
+ readrecord (source, source line)
+ ELSE source line := ""
+ FI
+ENDPROC source file ;
+
+TEXT PROC source file :
+ source file name
+ENDPROC source file ;
+
+PROC breakpoint handler :
+ determine return address ;
+ determine breakpoint nr ;
+ reset breakpoints ;
+ getcursor (x, y) ;
+ REP
+ ueberschrift schreiben ;
+ IF auto trace
+ THEN IF incharety = ""
+ THEN key := "s"
+ ELSE auto trace := FALSE
+ FI
+ FI ;
+ IF NOT auto trace
+ THEN REP
+ inchar (key)
+ UNTIL pos (""13"acdefgst", key) > 0 PER ;
+ IF key = "a"
+ THEN auto trace := TRUE ;
+ key := "s"
+ ELIF key = "f"
+ THEN out (""13""5"Sourcefile:") ;
+ getline (source file name) ;
+ out (""3"") ;
+ source file (source file name)
+ ELIF key = ""13""
+ THEN key := "s"
+ FI
+ FI ;
+ previous key := key
+ UNTIL pos ("gst", key) > 0 PER ;
+ cursor (1, 7) ;
+ out (""5"") ;
+ IF key <> "t"
+ THEN execute saved instruction
+ FI ;
+ IF key = "t"
+ THEN resetbreakpoints ;
+ term
+ ELIF key = "s"
+ THEN singlestep
+ FI ;
+ cursor (x, y) .
+
+ueberschrift schreiben :
+ feld loeschen ;
+ put (""1"Breakpoint") ; put (breakpoint nr) ;
+ put ("lbas:") ; put (hex16 (lbas)) ;
+ put ("pbas:") ; put (hex8 (packet base)) ;
+ put ("c8k:") ; put (hex8 (c8k)) ;
+ IF valid source
+ THEN out ("""") ; out (source file name) ; put ("""")
+ FI ;
+ line ;
+ IF valid source AND source line <> ""
+ THEN put (text (actual line number, 5)) ; put ("|") ;
+ outsubtext (source line, 1, 71) ;
+ line ;
+ IF LENGTH source line < 72
+ THEN put (text (actual line number +1, 5)) ; put ("|") ;
+ toline (source, actual line number +1) ;
+ out (subtext (source, 1, 71)) ;
+ toline (source, actual line number) ;
+ line
+ ELSE put ("______|") ;
+ outsubtext (source line, 72, 143) ;
+ line
+ FI
+ ELSE line (2)
+ FI ;
+ out (text (return segment AND 3)) ;
+ put (hex16 (return address)) ;
+ put ("|") ;
+ seg (breakpoint segment) ;
+ addr (breakpoint address) ;
+ zweizeilig := TRUE ;
+ disassemble one statement ;
+ IF auto trace
+ THEN pause (5)
+ FI ;
+ next instruction segment := breakpoint segment ;
+ next instruction address := addr ADD 1 ;
+ next instruction := getword (next instruction segment,
+ next instruction address) ;
+ line ;
+ put ("a)uto, s)tep, g)o, t)erm, d)stop, e)stop, c)lrerr, f)ile:") .
+
+feld loeschen :
+ out (""1"") ;
+ 7 TIMESOUT ""5""10"" ;
+ 79 TIMESOUT "-" .
+
+valid source :
+ exists (source file name) .
+
+disassemble one statement :
+ statement line := hex16 (get word (breakpoint segment, addr)) ;
+ statement line CAT " " ;
+ code word line (statement line) ;
+(* local base (lbas + offset) ; *)
+ statement line := opcode ;
+ local base (-1) ;
+ put (code word line) ;
+(* i := max (0, 26 - length (code word line)) ;
+ i TIMESOUT " " ; *)
+i:=0; i := 71 - LENGTH codeword line - i ;
+ outsubtext (statement line, 1, i) ;
+ line ;
+ IF zweizeilig
+ THEN put (" |") ;
+ outsubtext (statement line, i + 1, i + 72) ;
+ line
+ FI ;
+ codeword line ("") .
+
+singlestep :
+ IF is return opcode
+ THEN set breakpoint behind previous call
+ ELIF bool result
+ THEN set first breakpoint behind branch instruction ;
+ set second breakpoint at branch address ;
+ bool result (FALSE) ;
+ ELIF is bool return opcode
+ THEN set first breakpoint behind branch instruction at return address ;
+ set second breakpoint at branch address of branch instruction at
+ return address ;
+ ELIF is branch instruction
+ THEN set breakpoint at branch address
+ ELIF is call opcode AND NOT auto trace CAND segment 3 module CAND
+ yes (""3"Subroutine Trace")
+ THEN out (""3""13""5"") ;
+ calculate subroutine segment and address ;
+ set breakpoint behind next instruction
+ ELSE set breakpoint behind next instruction
+ FI .
+
+is call opcode :
+ (saved word AND opcode mask) = call opcode OR
+(* saved word = pcall opcode OR //einbauen, wenn local zugriffe ok sind// *)
+ saved word = -136 . (* LONGA CALL *)
+
+is line number :
+ (saved word AND opcode mask) = ln opcode OR
+ (saved word AND opcode mask) = lnlong opcode .
+
+is branch instruction :
+ (saved word AND opcode mask) = br opcode OR
+ (saved word AND opcode mask) = brlong opcode .
+
+is return opcode :
+ saved word = 32512 .
+
+is bool return opcode :
+ saved word = 32513 OR saved word = 32514 .
+
+read source line :
+ actual line number := ((saved word AND 768) * 2) OR (saved word AND 255);
+ IF saved word < 0
+ THEN actual line number INCR 256
+ FI ;
+ IF (saved word AND opcode mask) = lnlong opcode
+ THEN actual line number INCR 2048
+ FI ;
+ actual line number DECR 1 ;
+ IF valid source
+ THEN IF lineno (source) = actual line number CAND source line <> ""
+ THEN (* nichts*)
+ ELIF actual line number >= 0 AND actual line number <= lines(source)
+ THEN toline (source, actual line number) ;
+ readrecord (source, source line)
+ ELSE source line := ""
+ FI
+ ELSE source line := ""
+ FI .
+
+set first breakpoint behind branch instruction :
+ op word := next instruction AND opcode mask ;
+ IF op word = bf opcode OR op word = bflong opcode OR
+ op word = bt opcode OR op word = btlong opcode
+ THEN seg (next instruction segment) ;
+ addr (next instruction address) ;
+ out (""3"") ;
+ out (text (next instruction segment)) ;
+ put (hex16 (next instruction address)) ;
+ put ("|") ;
+ zweizeilig := FALSE ;
+ bool result (TRUE) ;
+ disassemble one statement ; (* Branch instruction *)
+ IF NOT auto trace
+ THEN pause (30)
+ ELSE pause (5)
+ FI ;
+ next free breakpoint ;
+ set breakpoint (i, next instruction segment,
+ next instruction address ADD 1) ;
+ ELSE putline (""3""7"Interner Fehler: Nach BOOL-Result folgt kein Branch");
+ LEAVE singlestep
+ FI .
+
+set second breakpoint at branch address :
+ calculate branch address ;
+ next free breakpoint ;
+ set breakpoint (i, next instruction segment, branch address) .
+
+set breakpoint at branch address :
+ next instruction := saved word ;
+ next instruction address := breakpoint address ;
+ calculate branch address ;
+ set breakpoint (breakpoint nr, next instruction segment, branch address) .
+
+set first breakpoint behind branch instruction at return address :
+ next instruction address := getword (local data segment,
+ lbas + return address offset) ;
+ next instruction segment := getword (local data segment,
+ lbas + return segment offset) AND 3 ;
+ next instruction := getword (next instruction segment,
+ next instruction address) ;
+ IF next instruction segment = 3
+ THEN set first breakpoint behind branch instruction
+ ELSE putline ("Trace beendet.")
+ FI .
+
+set second breakpoint at branch address of branch instruction at return address :
+ set second breakpoint at branch address .
+
+determine return address :
+ pause (0) ; (* Local Base fixieren *)
+ this local base := getword (local data segment, pcb (local base field)) ;
+ pause (0) ;
+ lbas := getword (local data segment, this local base +
+ previous local base offset) ;
+ c8k := getword (local data segment, this local base +
+ c8k offset) AND 255 ;
+ return segment := getword (local data segment, this local base +
+ return segment offset) ;
+ return address := getword (local data segment, this local base +
+ return address offset) ;
+ packet base := HIGH return segment ;
+ arith 16 ;
+ return address DECR 1 ;
+ arith 15 .
+
+segment 3 module :
+ IF saved word = -136 (* LONGA CALL *)
+ THEN op word := getword (breakpoint segment, breakpoint address ADD 1)
+ ELSE op word := saved word AND 1023 ;
+ IF saved word < 0
+ THEN op word INCR 1024
+ FI ;
+ FI ;
+ op word >= 1280 .
+
+calculate subroutine segment and address :
+ next instruction segment := 3 ; (* Laeuft nur in Segment 3 ! *)
+ next instruction address := getword (packet data segment,
+ begin of module nr link table + op word) ADD 1.
+
+determine breakpoint nr :
+ FOR i FROM 1 UPTO nr of breakpoints REP
+ IF breakpoints (i).set CAND
+ breakpoints (i).segment = (return segment AND 3) CAND
+ breakpoints (i).address = return address
+ THEN breakpoint nr := i ;
+ breakpoint address := breakpoints (i).address ;
+ breakpoint segment := breakpoints (i).segment ;
+ saved word := breakpoints (i).saved word ;
+ LEAVE determine breakpoint nr
+ FI
+ PER ;
+ put ("Returnaddresse:") ;
+ out (text (return segment AND 3)) ;
+ putline (hex16 (return address)) ;
+ list breakpoints ;
+ reset breakpoints ;
+ enablestop ;
+ errorstop ("Falsche Returnaddresse") .
+
+calculate branch address :
+ IF lowbyte replacement possible
+ THEN branch address := (next instruction address AND -256) OR
+ (next instruction AND 255) ;
+ LEAVE calculate branch address
+ FI ;
+ branch address := next instruction AND 768 ;
+ IF branch long
+ THEN branch address INCR 2048
+ FI ;
+ branch address INCR branch address ;
+ IF next instruction < 0
+ THEN branch address INCR 256
+ FI ;
+ arith 16 ;
+ branch address INCR (next instruction address AND -256) ;
+ IF HIGH branch address >= c8k
+ THEN branch address DECR 4096
+ FI ;
+ arith 15 ;
+ branch address := (branch address AND -256) OR (next instruction AND 255) .
+
+lowbyte replacement possible :
+ (next instruction AND -32000) = 0 .
+
+branch long :
+ bit (next instruction, 10) .
+
+execute saved instruction :
+ perhaps change error flags ;
+ putword (local data segment, this local base + return address offset,
+ return address) ;
+ putword (local data segment, this local base + return segment offset,
+ return segment) .
+
+perhaps change error flags :
+ IF bit (return segment, 7) AND previous key = "c"
+ THEN reset bit (return segment, 7)
+ FI ;
+ IF bit (return segment, 6) AND previous key = "e"
+ THEN reset bit (return segment, 6)
+ ELIF NOT bit (return segment, 6) AND previous key = "d"
+ THEN set bit (return segment, 6)
+ FI .
+
+set breakpoint behind next instruction :
+ IF is linenumber
+ THEN read source line
+ FI ;
+ set breakpoint (breakpoint nr, next instruction segment,
+ next instruction address) .
+
+set breakpoint behind previous call :
+ return segment := getword (local data segment,
+ lbas + return segment offset) AND 3 ;
+ return address := getword (local data segment,
+ lbas + return address offset) ;
+ IF return segment = 3
+ THEN set breakpoint (breakpoint nr, return segment, return address)
+ ELSE putline ("Trace beendet.")
+ FI .
+
+next free breakpoint :
+ FOR i FROM 1 UPTO nr of breakpoints REP
+ IF NOT breakpoints (i).set
+ THEN LEAVE next free breakpoint
+ FI
+ PER ;
+ putline (""3""7"Alle " + text(nr of breakpoints) + " Breakpoints sind belegt") ;
+ LEAVE singlestep .
+
+ENDPROC breakpoint handler ;
+
+INT OP HIGH (INT CONST word) :
+ TEXT VAR t := " " ;
+ replace (t, 1, word) ;
+ code (t SUB 2)
+ENDOP HIGH ;
+
+PROC reset breakpoints :
+ FOR i FROM 1 UPTO nr of breakpoints REP
+ IF breakpoints (i).set
+ THEN reset breakpoint (i)
+ ELSE breakpoints (i) := init breakpoint
+ FI
+ PER
+ENDPROC reset breakpoints ;
+
+PROC reset breakpoint (INT CONST nr) :
+ IF nr < 1 OR nr > nr of breakpoints
+ THEN errorstop ("Unzulaessige Breakpoint Nummer")
+ ELIF NOT breakpoints (nr).set
+ THEN display ("Warnung: Breakpoint " + text (nr) + " war nicht gesetzt")
+ ELSE putword (breakpoints (nr).segment, breakpoints (nr).address,
+ breakpoints (nr).saved word) ;
+ breakpoints (nr) := init breakpoint
+ FI
+ENDPROC reset breakpoint ;
+
+PROC set breakpoint (INT CONST nr, segment, address) :
+ INT VAR new word ;
+ IF nr < 1 OR nr > nr of breakpoints
+ THEN errorstop ("Unzulaessige Breakpoint Nummer")
+ ELIF breakpoints (nr).set
+ THEN errorstop ("Breakpoint " + text (nr) + " ist bereits gesetzt")
+ ELIF segment < 2 OR segment > 3
+ THEN errorstop ("Segment " + text (segment) + " ist kein Codesegment")
+ ELSE breakpoints (nr).segment := segment ;
+ breakpoints (nr).address := address ;
+ breakpoints (nr).saved word := get word (segment, address) ;
+ new word := call opcode + (handler module AND 1023) ;
+ IF handler module >= 1024
+ THEN setbit (new word, 15)
+ FI ;
+ putword (segment, address, new word) ;
+ IF getword (segment, address) <> new word
+ THEN errorstop ("Addresse Schreibgeschuetzt")
+ ELSE breakpoints (nr).set := TRUE
+ FI
+ FI
+ENDPROC set breakpoint ;
+
+PROC handlers module nr (INT CONST module nr) :
+ handler module := module nr
+ENDPROC handlers module nr ;
+
+INT PROC handlers module nr :
+ handler module
+ENDPROC handlers module nr ;
+
+PROC set breakpoint :
+ handlers module nr (module number ("breakpointhandler", 1)) ;
+ auto trace := FALSE ;
+ source file name := "" ;
+ actual line number := -1 ;
+ page ;
+ TEXT VAR object ;
+ INT VAR object nr ;
+ put ("Object Name:") ;
+ getline (object) ;
+ changeall (object, " ", "") ;
+ putline ("Objekt von Anfang an abzaehlen") ;
+ pause (5) ;
+ help (object) ;
+ put ("Objekt Nr:") ;
+ get (object nr) ;
+ INT VAR code address := code start (object, object nr) ADD 1 ;
+ naechsten freien breakpoint setzen ;
+ put ("Breakpoint") ;
+ put (i) ;
+ putline ("wurde gesetzt.") .
+
+naechsten freien breakpoint setzen :
+ FOR i FROM 1 UPTO nr of breakpoints REP
+ IF NOT breakpoints (i).set
+ THEN set breakpoint (i, code segment, code address) ;
+ LEAVE naechsten freien breakpoint setzen
+ FI
+ PER ;
+ errorstop ("Alle " + text (nr of breakpoints) + " Breakpoints sind belegt").
+
+ENDPROC set breakpoint ;
+
+PROC list breakpoints :
+ line ;
+ putline (" No Set Address Word") ;
+ FOR i FROM 1 UPTO nr of breakpoints REP
+ put (text (i, 3)) ;
+ IF breakpoints (i).set
+ THEN put (" Y ")
+ ELSE put (" N ")
+ FI ;
+ out (text (breakpoints (i).segment)) ;
+ put (hex16 (breakpoints (i).address)) ;
+ put(" ") ;
+ put (hex16 (breakpoints (i).saved word)) ;
+ line
+ PER
+ENDPROC list breakpoints ;
+
+ENDPACKET tracer
diff --git a/devel/misc/unknown/src/XLIST.ELA b/devel/misc/unknown/src/XLIST.ELA new file mode 100644 index 0000000..4897dab --- /dev/null +++ b/devel/misc/unknown/src/XLIST.ELA @@ -0,0 +1,143 @@ +PACKET xlist DEFINES xlist : (* M. Staubermann, 1.8.0 861203 *)
+ (* Heapsize korrigiert 870711 *)
+DATASPACE VAR ds, act ;
+
+PROC x list :
+ ds := nilspace ;
+ FILE VAR f := sequentialfile (output, ds) ;
+ headline (f, "Dataspaces:" + text (dataspaces) +
+ " Speicher:" + text (storage (myself))) ;
+ disablestop ;
+ xlist (f) ;
+ show (f) ;
+ forget (ds) ;
+ENDPROC x list ;
+
+PROC x list (FILE VAR f) :
+ INT VAR i, acttype, heapsiz, seiten ;
+ TEXT VAR name, status ;
+ FILE VAR f2 ;
+ ROW 255 STRUCT (TEXT name, status) VAR names ;
+
+ enablestop ;
+ FOR i FROM 1 UPTO 255 REP
+ names (i).name := "" ;
+ names (i).status := ""
+ PER ;
+ begin list ;
+ get list entry (name, status) ;
+ WHILE name <> "" REP
+ makeid (old (name)) ;
+ names (dsnr).name := name ;
+ names (dsnr).status := status ;
+ get list entry (name, status)
+ PER ;
+ maxlinelength (f, 1000) ;
+ putline (f, "Datum Status Ds kB Type HeapLines Segs S/L ""Name""/'Headline'");
+ line (f) ;
+ putline (f, " 4 " + text ((pages (4, myself)+1) DIV 2, 5) +
+ " " + text (heapsize, 3) + " - - -") ;
+ disablestop ;
+ FOR i FROM 5 UPTO 255 REP
+ cout (i) ;
+ makeid (i) ;
+ act := reveal ds ;
+ IF iserror
+ THEN clearerror
+ ELSE name := names (i).name ;
+ status := names (i).status ;
+ acttype := type (act) ;
+ names (i).name := "" ;
+ names (i).status := "" ;
+ put (f, stat + id + " " + speicher + " " + typ + " " + heap) ;
+ putline (f, zeilen + " " + segmente + " " + sl percent + dsname) ;
+ FI ;
+ forget (act) ;
+ IF iserror THEN puterror ; clearerror FI
+ PER .
+
+dsname :
+ IF name = ""
+ THEN IF act type = 1003
+ THEN " '" + headline (f2) + "'"
+ ELSE ""
+ FI
+ ELSE " """ + name + """"
+ FI .
+
+stat :
+ IF status = ""
+ THEN " "
+ ELSE status
+ FI .
+
+typ:
+ text (act type, 5) .
+
+id :
+ text (i, 3) .
+
+speicher :
+ seiten := ds pages (act) ;
+ text ((seiten+1) DIV 2, 5) .
+
+zeilen :
+ IF act type <> 1003 THEN " -"
+ ELSE f2 := sequentialfile (modify, act) ;
+ text (lines (f2), 4)
+ FI .
+
+segmente :
+ IF act type <> 1003 THEN " -"
+ ELSE INT CONST segs :: segments (f2) ;
+ text (segs, 4)
+ FI .
+
+sl percent:
+ IF act type <> 1003 THEN " - "
+ ELIF segs = 1 THEN " "
+ ELSE text (int (real (segs) * 100.0 / real (lines (f2))+0.5), 2) + "%"
+ FI .
+
+heap :
+ heapsiz:= heapsize (act) * 2 ;
+ IF heapsiz >= 2046
+ THEN " -"
+ ELIF act type = 1003
+ THEN IF heapsiz < 192
+ THEN " 0"
+ ELSE text ((heapsiz-192) DIV 2, 4)
+ FI
+ ELSE INT CONST next page :: next ds page (act, seiten) ;
+ IF next page < 0
+ THEN " 0"
+ ELIF heapsiz = next page
+ THEN " 1"
+ ELSE text ((heapsiz + 1 - next page) DIV 2, 4)
+ FI
+ FI .
+
+ENDPROC x list ;
+
+PROC make id (DATASPACE CONST ds) :
+ BOUND INT VAR i := ds
+ENDPROC make id ;
+
+INT PROC dsnr :
+ INT VAR id ;
+ id AND 255
+ENDPROC dsnr ;
+
+PROC makeid (INT CONST nr) :
+ INT VAR dsid := nr + 256 * index (myself)
+ENDPROC makeid ;
+
+DATASPACE PROC reveal ds :
+ DATASPACE VAR ds ; ds
+ENDPROC reveal ds ;
+
+INT PROC pages (INT CONST dsnr, TASK CONST task) :
+ EXTERNAL 88
+ENDPROC pages ;
+
+ENDPACKET x list ;
diff --git a/devel/misc/unknown/src/XSTATUS.ELA b/devel/misc/unknown/src/XSTATUS.ELA new file mode 100644 index 0000000..36abc23 --- /dev/null +++ b/devel/misc/unknown/src/XSTATUS.ELA @@ -0,0 +1,188 @@ +PACKET x taskinfo DEFINES x task status , (* M.Staubermann 1.8.0, 861009*)
+ x task info :
+
+INT PROC pcf (TASK CONST t, INT CONST byte) :
+ TEXT VAR word := " " ;
+ replace (word, 1, pcb (t, byte DIV 2 + 17)) ;
+ IF (byte AND 1) = 0 THEN code (word SUB 1)
+ ELSE code (word SUB 2)
+ FI
+ENDPROC pcf ;
+
+TEXT PROC xstatus (TASK CONST task, INT CONST depth) :
+ TEXT VAR zeile := ".................." ,
+ task name := name (task) ;
+ change (zeile, 1, length (task name) + depth , depth * " " + task name) ;
+ task name := zeile ;
+ zeile CAT " " + hex16 (pcb (task, 9)) + "-" + hex8 (pcb (task, 10)) ;
+ IF bit (pcf (task, 5), 7) (* ^ tasknr & version *)
+ THEN zeile CAT "x"
+ ELSE zeile CAT " "
+ FI ;
+ IF bit (pcf (task, 5), 0)
+ THEN zeile CAT "h" (* comflg *)
+ ELSE zeile CAT " " (* haltprocess liegt an *)
+ FI ;
+ zeile CAT status (pcf (task, 6)) ; (* status *)
+ zeile CAT " " + bin (pcf (task, 7), 3, 7) ; (* statusflags rstflg *)
+ INT CONST pcf 11 :: pcf (task, 11) ;
+ IF bit (pcf 11, 7) (* iserror *)
+ THEN zeile CAT " e"
+ ELSE zeile CAT " n"
+ FI ;
+ IF bit (pcf 11, 6) (* disablestop *)
+ THEN zeile CAT "d"
+ ELSE zeile CAT "e"
+ FI ;
+ IF bit (pcf 11, 5) (* unbelegt *)
+ THEN zeile CAT "*"
+ ELSE zeile CAT " "
+ FI ;
+ IF bit (pcf 11, 4) (* arith 16 *)
+ THEN zeile CAT "u" (* unsigned *)
+ ELSE zeile CAT "s" (* signed *)
+ FI ;
+ zeile CAT " " + text (pcf 11 AND 3) ; (* codesegment *)
+ zeile CAT hex8 (pcf (task, 10)) + hex8 (pcf (task, 9)) ; (* icount *)
+ zeile CAT " " + text (pcb (task, 28) AND 15) ; (* heapsegment *)
+ zeile CAT hex16 (pcb (task, 28) AND -16) ; (* heaptop *)
+ zeile CAT " " + hex16 (pcb (task, 23)) ; (* mod *)
+ zeile CAT text (pcb (task, 4), 4) ; (* channel *)
+ zeile CAT text (pcb (task, 1), 4) ; (* linenr *)
+ zeile CAT text (pcb (task, 2), 4) ; (* errorline *)
+ zeile CAT text (pcb (task, 3), 4) ; (* errorcode *)
+ zeile CAT text (pcb (task, 7), 4) ; (* msgcode *)
+ zeile CAT " " + hex16 (pcb (task, 8)) ; (* msgds *)
+ zeile CAT " " + hex16 (pcb (task, 11)) + "-" + hex8 (pcb (task, 12)) ;
+ zeile CAT " " + hex8 (pcf (task, 29)) ; (* priv *)
+ zeile CAT " " + hex8 (pcf (task, 14)) ; (* pbas *) (* ^ fromid *)
+ zeile CAT " " + hex8 (pcf (task, 15)) ; (* c8k *)
+ zeile CAT " " + hex16 (pcb (task, 25)) ; (* lbas *)
+ zeile CAT " " + hex16 (pcb (task, 26)) ; (* ltop *)
+ zeile CAT " " + hex16 (pcb (task, 27)) ; (* ls_top *)
+ zeile CAT text (pcb (task, 6), 3) ; (* prio *)
+ zeile CAT " " + hex8 (pcf (task, 28)) ; (* priclk *)
+ zeile CAT " " + hex8 (pcf (task, 8)) ; (* pricnt *)
+ zeile CAT " " + hex16(pcb (task, 17)) + hex16 (pcb (task, 18)) ;
+ zeile CAT " " + hex8 (pcf (task, 4)) ; (* millis *) (* ^ wstate *)
+ zeile
+ENDPROC xstatus ;
+
+TEXT PROC status (INT CONST wert) :
+ stat + blocked .
+
+stat:
+ SELECT (wert AND 60) DIV 4 OF
+ CASE 0 : "INTER"
+ CASE 1 : "OUT "
+ CASE 2 : "INCHR"
+ CASE 3 : "PAUSE"
+ CASE 4 : "RTN T"
+ CASE 5 : "RTN F"
+ CASE 6 : "CALL "
+ CASE 7 : "RTN "
+ CASE 8 : "CHGB1"
+ CASE 9 : "CHGB2"
+ CASE 10: "CHGB3"
+ CASE 15: IF wert = 255 THEN "-DEAD" ELSE "WAIT " FI
+ OTHERWISE "?? "+hex8 (wert AND 252)
+ ENDSELECT .
+
+blocked:
+ IF (wert AND 1) = 1
+ THEN "-B"
+ ELSE " "
+ FI
+ENDPROC status ;
+
+TEXT PROC hex8 (INT CONST wert) :
+ hex digit (wert DIV 16) +
+ hex digit (wert AND 15)
+ENDPROC hex8 ;
+
+TEXT PROC hex16 (INT CONST wert) :
+ TEXT VAR t := " " ;
+ replace (t, 1, wert) ;
+ hex digit (code (t SUB 2) DIV 16) +
+ hex digit (code (t SUB 2) AND 15) +
+ hex digit (code (t SUB 1) DIV 16) +
+ hex digit (code (t SUB 1) AND 15)
+ENDPROC hex16 ;
+
+TEXT PROC hex digit (INT CONST wert) :
+ "0123456789ABCDEF" SUB (wert+1)
+ENDPROC hex digit ;
+
+TEXT PROC bin (INT CONST wert, from, to) :
+ INT VAR i ;
+ TEXT VAR t := "" ;
+ FOR i FROM to DOWNTO from REP
+ IF bit (wert, i) THEN t CAT "1"
+ ELSE t CAT "0"
+ FI
+ PER ;
+ t
+ENDPROC bin ;
+
+PROC x task info (FILE VAR list file) :
+ access catalogue ;
+ put (list file, date) ;
+ put (list file, " ") ;
+ put (list file, time of day) ;
+ put (list file, " Size:") ;
+ INT VAR size, used ;
+ storage (size, used) ;
+ put (list file, size) ;
+ put (list file, "K Used:") ;
+ put (list file, used) ;
+ put (list file, "K ") ;
+ line (list file) ;
+ put (list file, "TASK ") ;
+ put (list file, "taskid xhstatus rstflg edxa icount hptop mod chn") ;
+ write (list file, "lin eln ecd mcd mgds fromid prvpbs c8k lbs ltoplstop");
+ put (list file, "pripck pct wstate mls") ;
+ line (list file) ;
+ list tree (list file, supervisor, 0)
+ENDPROC x task info ;
+
+DATASPACE VAR ds ;
+PROC x task info :
+ disable stop ;
+ ds := nilspace ;
+ FILE VAR list file := sequentialfile (output, ds) ;
+ max line length (list file, 1000) ;
+ x task info (list file) ;
+ edit (list file) ;
+ forget (ds) ;
+ENDPROC x task info ;
+
+PROC list tree (FILE VAR list file, TASK CONST first son, INT CONST depth) :
+ enable stop ;
+ TASK VAR actual task := first son ;
+ WHILE NOT isniltask (actual task) REP
+ list actual task ;
+ list tree (list file, son (actual task), depth + 1) ;
+ actual task := brother (actual task)
+ PER .
+
+list actual task :
+ putline (list file, x status (actual task, depth))
+
+ENDPROC list tree ;
+
+PROC x task status (TASK CONST t) :
+ TEXT VAR zeile := x status (t, 0) ;
+ line ;
+ put ("Task:") ; putline (name (t)) ;
+ putline ("taskid xhstatus rstflg edxa icount hptop mod chn lin eln ecd") ;
+ putline (subtext (zeile, 20, 80)) ;
+ putline ("mcd mgds fromid prvpbs c8k lbs ltoplstoppripck pct wstate mls") ;
+ putline (subtext (zeile, 81)) ;
+ line
+ENDPROC x task status ;
+
+PROC x task status :
+ x task status (myself)
+ENDPROC x task status ;
+
+ENDPACKET x task info ;
diff --git a/devel/misc/unknown/src/Z80.ELA b/devel/misc/unknown/src/Z80.ELA new file mode 100644 index 0000000..58e31bf --- /dev/null +++ b/devel/misc/unknown/src/Z80.ELA @@ -0,0 +1,495 @@ +PACKET z80 disassembler DEFINES hex, dez, disassemble, disass , acht :
+
+LET max = 4096; (* Anzahl Bytes der ROW DIV 2 *)
+
+BOUND ROW max INT VAR row;
+
+INT VAR next byte,
+ next word,
+ byte,
+ div 8,
+ and 7,
+ and f,
+ div 10;
+TEXT VAR index;
+
+belegen (0,0,0);
+
+INT PROC dez (TEXT CONST wert) :
+ TEXT VAR zahl := wert;
+ INT VAR i;
+ REAL VAR summe := 0.0;
+ IF (zahl SUB 1) = "!" THEN int(subtext(zahl, 2))
+ ELIF (zahl SUB 1) = "%" THEN zahl := subtext(zahl, 2);
+ FOR i FROM length(zahl) DOWNTO 1 REP
+ summe INCR (2.0**(length(zahl) - i))* real(number)
+ PER;
+ IF summe > 32767.0 THEN int (summe - 65536.0)
+ ELSE int (summe)
+ FI
+ ELSE IF (zahl SUB 1) = "$" THEN zahl := subtext(zahl, 2) FI;
+ FOR i FROM length(zahl) DOWNTO 1 REP
+ summe INCR (16.0**(length(zahl) - i))* real(number)
+ PER;
+ IF summe > 32767.0 THEN int (summe - 65536.0)
+ ELSE int (summe)
+ FI
+ FI.
+
+number :
+ IF (zahl SUB i) > "9"
+ THEN code( zahl SUB i) -55
+ ELSE int (zahl SUB i)
+ FI
+ENDPROC dez;
+
+PROC disassemble (TEXT CONST source code) :
+ row := old(source code);
+ INT VAR counter, start, pc, b1, b2, b3, b4, ende;
+ TEXT VAR addr;
+ page;
+ out (" "15" Z80 - DISASSEMBLER "14""13""10""10"");
+ out ("F r Adressangaben: $ = hex, % = bin„ r, ! = dezimal."13""10""10"");
+ out ("Hexadezimale Eingaben mit den Zeichen 0 bis F."13""10""10"");
+ out ("Disassemblierung mit ESC abbrechen."13""10""10"");
+ out ("Addresse des ersten Eintrags der Liste:");
+ addr:="$0000";
+ editget(addr);
+ start := dez(addr);
+ REP
+ REP
+ out (""10""13"");
+ out ("Startaddresse f r Disassemblierung :");
+ addr:="$0000";
+ editget (addr);
+ pc := dez(addr);
+ UNTIL positive int (pc) >= positive int (start) PER;
+ REP
+ out (""10""13"");
+ out ("Endaddresse f r Disassemblierung :");
+ addr:="$FFFF";
+ editget (addr);
+ out (""10""13"");
+ ende := dez(addr);
+ UNTIL positive int (ende) >= positive int (pc) PER;
+ REP
+ berechne b1 bis b4;
+ put (text(hex(pc),4));
+ put("");
+ dump;
+ put (" ");
+ disass (b1, b2, b3, b4, pc);
+ line;
+ UNTIL isincharety (""27"") OR positiveint (pc) > positive int (ende) PER
+ UNTIL no ("Noch weitere Bereiche disassemblieren") PER.
+
+berechne b1 bis b4 :
+ counter := pc - start;
+ b1 := acht (counter );
+ b2 := acht (counter + 1);
+ b3 := acht (counter + 2);
+ b4 := acht (counter + 3).
+
+dump :
+ put ( text(hex(b1),3)+
+ text(hex(b2),3)+
+ text(hex(b3),3)+
+ text(hex(b4),3));
+ put (""142"" + ascii(b1) + ascii(b2) + ascii(b3) + ascii(b4) + ""143"");
+
+ENDPROC disassemble;
+
+TEXT PROC ascii (INT CONST byte) :
+ IF (byte MOD 128) < 32 OR (byte MOD 128) = 127 THEN "."
+ ELSE code(byte)
+ FI
+ENDPROC ascii;
+
+REAL PROC positive int (INT CONST wert) :
+ IF wert < 0 THEN real(wert) + 65536.0
+ ELSE real(wert)
+ FI
+ENDPROC positive int;
+
+
+INT PROC acht (INT CONST pos) :
+ IF (pos DIV 2) + 1 > max THEN LEAVE acht WITH 0 FI;
+ INT CONST word := row (pos DIV 2 + 1);
+ TEXT VAR w := " ";
+ replace (w, 1, word) ;
+ IF (pos MOD 2) = 1 THEN code(w SUB 1)
+ ELSE code(w SUB 2)
+ FI
+ENDPROC acht;
+
+TEXT PROC hex (INT CONST zahl) :
+ IF zahl < 0
+ THEN digit (((zahl XOR -1) DIV 4096) XOR 15) +
+ hex (zahl MOD 4096)
+ ELIF zahl < 16
+ THEN digit (zahl)
+ ELSE hex (zahl DIV 16) + digit (zahl MOD 16)
+ FI
+ENDPROC hex;
+
+TEXT PROC digit (INT CONST d) :
+ IF d < 10
+ THEN code(d + 48)
+ ELSE code(d + 55)
+ FI
+ENDPROC digit;
+
+PROC belegen (INT CONST b1, b2, b3) :
+ byte := b1;
+ next byte := b2;
+ next word := (code(b3)+code(b2)) ISUB 1;
+ and 7 := byte AND 7;
+ and f := byte AND 15;
+ div 10:= byte DIV 16;
+ div 8 := byte DIV 8 AND 7;
+ENDPROC belegen;
+
+PROC counter incr 1 (INT CONST b2, b3, b4) :
+ byte := b2;
+ next byte := b3;
+ next word := (code(b4)+code(b3)) ISUB 1;
+ and 7 := byte AND 7;
+ and f := byte AND 15;
+ div 10:= byte DIV 16;
+ div 8 := byte DIV 8 AND 7;
+ENDPROC counter incr 1;
+
+PROC counter incr 2 (INT CONST b3, b4) :
+ byte := b3;
+ next byte := b4;
+ next word := b4;
+ and 7 := byte AND 7;
+ and f := byte AND 15;
+ div 10:= byte DIV 16;
+ div 8 := byte DIV 8 AND 7;
+ENDPROC counter incr 2;
+
+PROC disass (INT CONST b1, b2, b3, b4, INT VAR counter):
+ counter INCR int disass (b1, b2, b3, b4, counter)
+ENDPROC disass;
+
+TEXT PROC arith log :
+ SELECT div 8 OF
+ CASE 0 : "ADD"
+ CASE 1 : "ADC"
+ CASE 2 : "SUB"
+ CASE 3 : "SBC"
+ CASE 4 : "AND"
+ CASE 5 : "XOR"
+ CASE 6 : "OR"
+ CASE 7 : "CP"
+ OTHERWISE "???"
+ ENDSELECT
+
+ENDPROC arith log;
+
+TEXT PROC reg1 :
+ SELECT div8 OF
+ CASE 0 : "B"
+ CASE 1 : "C"
+ CASE 2 : "D"
+ CASE 3 : "E"
+ CASE 4 : "H"
+ CASE 5 : "L"
+ CASE 6 : "(HL)"
+ CASE 7 : "A"
+ OTHERWISE "???"
+ ENDSELECT
+
+ENDPROC reg1;
+
+TEXT PROC reg2 :
+ SELECT and7 OF
+ CASE 0 : "B"
+ CASE 1 : "C"
+ CASE 2 : "D"
+ CASE 3 : "E"
+ CASE 4 : "H"
+ CASE 5 : "L"
+ CASE 6 : "(HL)"
+ CASE 7 : "A"
+ OTHERWISE "???"
+ ENDSELECT
+
+ENDPROC reg2;
+
+TEXT PROC rp:
+ SELECT div10 AND 3 OF
+ CASE 0 : "BC"
+ CASE 1 : "DE"
+ CASE 2 : "HL"
+ CASE 3 : "SP"
+ OTHERWISE "???"
+ ENDSELECT
+
+ENDPROC rp;
+
+
+INT PROC bitmanipulation :
+ SELECT byte DIV 32 OF
+ CASE 1 : write ("BIT "+text(div8)+","+reg2);2
+ CASE 2 : write ("RES "+text(div8)+","+reg2);2
+ CASE 3 : write ("SET "+text(div8)+","+reg2);2
+ OTHERWISE write("??? $"+hex(next byte));1
+ ENDSELECT
+
+ENDPROC bitmanipulation;
+
+BOOL PROC is special instruction :
+ byte > 192 AND (and 7 = 3 OR
+ and 7 = 6 OR
+ and f = 9 )
+OR byte < 64 AND (and 7 = 7 OR
+ and 7 = 0 OR
+ and 7 = 2 ) .
+
+ENDPROC is special instruction;
+
+INT PROC int disass (INT CONST b1, b2, b3, b4, counter) :
+ belegen (b1, b2, b3);
+ IF is special instruction
+ THEN disass special instruction
+ ELIF div 10 < 4
+ THEN lower case instruction
+ ELIF div 10 < 128
+ THEN ld instruction
+ ELIF div 10 < 192
+ THEN arith log instruction
+ ELSE higher case instruction
+ FI.
+
+arith log instruction :
+ write (arith log+" "+reg 2);1 .
+
+ld instruction :
+ write ("LD "+reg 1+","+reg 2);1 .
+
+condition code :
+ SELECT div8 OF
+ CASE 0 : "NZ"
+ CASE 1 : "Z"
+ CASE 2 : "NC"
+ CASE 3 : "C"
+ CASE 4 : "PO"
+ CASE 5 : "PE"
+ CASE 6 : "P"
+ CASE 7 : "M"
+ OTHERWISE "???"
+ ENDSELECT.
+
+lower case instruction :
+ IF and f = 1 THEN write ("LD "+rp+",$"+hex(next word));3
+ ELIF and 7 = 3 THEN write ("INC "+rp);1
+ ELIF and 7 = 4 THEN write ("INC "+reg1);1
+ ELIF and 7 = 5 THEN write ("DEC "+reg1);1
+ ELIF and 7 = 6 THEN write ("LD "+reg1+",$"+hex(next byte));2
+ ELIF and f = 9 THEN write ("ADD HL,"+rp);1
+ ELIF and f =11 THEN write ("DEC "+rp);1
+ ELSE write ("??? $"+hex(next byte));1
+ FI.
+
+higher case instruction :
+ SELECT and 7 OF
+ CASE 0 : write ("RET "+condition code);1
+ CASE 1 : write ("POP "+rp);1
+ CASE 2 : write ("JP "+condition code+",$"+hex(next word));3
+ CASE 4 : write ("CALL "+condition code+",$"+hex(next word));3
+ CASE 5 : write ("PUSH "+rp);1
+ CASE 7 : write ("RST "+text(div 8));1
+ OTHERWISE write ("??? $"+hex(next byte));1
+ ENDSELECT.
+
+
+branchaddress :
+ "$" + hex(counter + displacement) .
+
+displacement :
+ IF next byte < 128
+ THEN next byte + 2
+ ELSE next byte - 254
+ FI.
+
+cb instructions :
+ counter incr 1 (b2, b3, b4);
+ SELECT div 8 OF
+ CASE 0 : write ("RCC "+reg2);2
+ CASE 1 : write ("RRC "+reg2);2
+ CASE 2 : write ("RL "+reg2);2
+ CASE 3 : write ("RR "+reg2);2
+ CASE 4 : write ("SLA "+reg2);2
+ CASE 5 : write ("SRA "+reg2);2
+ CASE 6 : write ("SLL "+reg2);2
+ CASE 7 : write ("SLR "+reg2);2
+ OTHERWISE bitmanipulation
+ ENDSELECT .
+
+disass special instruction :
+ SELECT byte OF
+ CASE 0 : write ("NOP");1
+ CASE 2 : write ("LD (BC),A");1
+ CASE 7 : write ("RLCA");1
+ CASE 8 : write ("EX AF,AF'");1
+ CASE 10 : write ("LD A,(BC)");1
+ CASE 15 : write ("RRCA");1
+ CASE 16 : write ("DJNZ "+branchaddress);2
+ CASE 18 : write ("LD (DE),A");1
+ CASE 23 : write ("RLA");1
+ CASE 24 : write ("JR "+branchaddress);2
+ CASE 26 : write ("LD A,(DE)");1
+ CASE 31 : write ("RRA");1
+ CASE 32 : write ("JR NZ,"+branchaddress);2
+ CASE 34 : write ("LD ($"+hex (next word)+"),HL");3
+ CASE 39 : write ("DAA");1
+ CASE 40 : write ("JR Z,"+branchaddress);2
+ CASE 42 : write ("LD HL,($"+hex(next word)+")");3
+ CASE 47 : write ("CPL");1
+ CASE 48 : write ("JR NC,"+branchaddress);2
+ CASE 50 : write ("LD ($"+hex(next word)+"),A");3
+ CASE 55 : write ("SCF");1
+ CASE 56 : write ("JR C,"+branchaddress);2
+ CASE 58 : write ("LD A,($"+hex(next word)+")");3
+ CASE 63 : write ("CCF");1
+ CASE 118: write ("HALT");1
+ CASE 195: write ("JP $"+hex(next word));3
+ CASE 198: write ("ADD A,$"+hex(next byte));2
+ CASE 201: write ("RET");1
+ CASE 203: cb instructions
+ CASE 205: write ("CALL $"+hex(next word));3
+ CASE 206: write ("ADC A,$"+hex(next byte));2
+ CASE 211: write ("OUT ($"+hex(next byte)+")");2
+ CASE 214: write ("SUB A,$"+hex(next byte));2
+ CASE 217: write ("EXX");1
+ CASE 219: write ("IN ($"+hex(next byte)+")");2
+ CASE 221: index := "IX"; dd and fd instructions
+ CASE 222: write ("SBC A,$"+hex(next byte));2
+ CASE 227: write ("EX (SP),HL");1
+ CASE 230: write ("AND $"+hex(next byte));2
+ CASE 233: write ("JP (HL)");1
+ CASE 235: write ("EX DE,HL");1
+ CASE 237: ed instructions
+ CASE 238: write ("XOR $"+hex(next byte));2
+ CASE 243: write ("DI");1
+ CASE 246: write ("OR $"+hex(next byte));2
+ CASE 249: write ("LD SP,HL");2
+ CASE 251: write ("EI");1
+ CASE 253: index := "IY"; dd and fd instructions
+ CASE 254: write ("CP $"+hex(next byte));2
+ OTHERWISE write ("??? $"+hex(byte));1
+ ENDSELECT.
+
+dd and fd instructions :
+ counter incr 1 (b2, b3, b4);
+ SELECT byte OF
+ CASE 33 : write ("LD "+index+",$"+hex(next word));4
+ CASE 34 : write ("LD ($"+hex(next word)+"),"+index);4
+ CASE 35 : write ("INC "+index);2
+ CASE 42 : write ("LD "+index+",($"+hex(next word)+")");4
+ CASE 43 : write ("DEC "+index);2
+ CASE 52 : write ("INC ("+index+"+$"+hex(next byte)+")");2
+ CASE 53 : write ("DEC ("+index+"+$"+hex(next byte)+")");2
+ CASE 203: dd and fd cb instructions
+ CASE 225: write ("POP "+index);2
+ CASE 227: write ("EX (SP),"+index);2
+ CASE 229: write ("PUSH "+index);2
+ CASE 233: write ("JP ("+index+")");2
+ CASE 249: write ("LD SP,"+index);2
+ OTHERWISE calculated dd and fd instructions
+ ENDSELECT.
+
+calculated dd and fd instructions :
+ IF andf = 9 THEN write ("ADD "+index+","+rp);2
+ ELIF and7 = 6 AND div 10 > 3 AND div 10 < 8
+ THEN write ("LD "+reg1+",("+index+"+$"+hex(next byte)+")");3
+ ELIF div 10 = 7 AND byte <> 118
+ THEN write ("LD ("+index+"+$"+hex(next byte)+"),"+reg2);3
+ ELIF and7 = 6 AND div 10 > 7 AND div 10 < 12
+ THEN write (arith log+" ("+index+"+$"+hex(next byte)+")");3
+ ELSE write ("??? $DD/FD "+hex(byte));2
+ FI.
+
+dd and fd cb instructions :
+ counter incr 2 (b4, b3);
+ IF and7 <> 6 THEN write ("??? $DD/FD "+hex(byte));3
+ ELSE SELECT div 8 OF
+ CASE 0 : write ("RLC ("+index+"+$"+hex(next byte)+")");4
+ CASE 1 : write ("RRC ("+index+"+$"+hex(next byte)+")");4
+ CASE 2 : write ("RL ("+index+"+$"+hex(next byte)+")");4
+ CASE 3 : write ("RR ("+index+"+$"+hex(next byte)+")");4
+ CASE 4 : write ("SLA ("+index+"+$"+hex(next byte)+")");4
+ CASE 5 : write ("SRA ("+index+"+$"+hex(next byte)+")");4
+ CASE 6 : write ("SLL ("+index+"+$"+hex(next byte)+")");4
+ CASE 7 : write ("SRL ("+index+"+$"+hex(next byte)+")");4
+ OTHERWISE dd and fd bitmanipulation
+ ENDSELECT
+ FI.
+
+dd and fd bitmanipulation :
+ SELECT byte DIV 32 OF
+ CASE 1 : write ("BIT "+text(div8)+",("+index+"+$"+hex(next byte)+")");4
+ CASE 2 : write ("RES "+text(div8)+",("+index+"+$"+hex(next byte)+")");4
+ CASE 3 : write ("SET "+text(div8)+",("+index+"+$"+hex(next byte)+")");4
+ OTHERWISE write ("??? $DD/FD CB "+hex(next byte)+" "+hex(byte));4
+ ENDSELECT.
+
+ed instructions :
+ counter incr 1 (b2, b3, b4);
+ SELECT byte OF
+ CASE 68 : write ("NEG");2
+ CASE 69 : write ("RETN");2
+ CASE 70 : write ("IM 0");2
+ CASE 71 : write ("LD I,A");2
+ CASE 77 : write ("RETI");2
+ CASE 79 : write ("LD R,A");2
+ CASE 86 : write ("IM 1");2
+ CASE 87 : write ("LD A,I");2
+ CASE 94 : write ("IM 2");2
+ CASE 95 : write ("LD A,R");2
+ CASE 103: write ("RRD");2
+ CASE 111: write ("RLD");2
+ CASE 171: write ("OUTD");2
+ CASE 163: write ("OUTI");2
+ CASE 179: write ("OTIR");2
+ CASE 187: write ("OTDR");2
+ OTHERWISE calculate ed instruction
+ ENDSELECT.
+
+
+ENDPROC int disass ;
+
+INT PROC calculate ed instruction :
+ IF and7 = 0 AND is 40 to 7f THEN write ("IN "+reg1+",(C)");2
+ ELIF and7 = 1 AND is 40 to 7f THEN write ("OUT "+reg1+",(C)");2
+ ELIF andf = 2 AND is 40 to 7f THEN write ("SBC HL,"+rp);2
+ ELIF andf = 3 AND is 40 to 7f THEN write ("LD ($"+hex(nextword)+"),"+rp);4
+ ELIF andf =11 AND is 40 to 7f THEN write ("LD "+rp+",($"+hex(nextword)+")");4
+ ELIF andf =10 AND is 40 to 7f THEN write ("ADC HL,"+rp);2
+ ELIF div10 = 10 OR div10 = 11 THEN
+ IF and7 = 0 THEN write ("LD"+modification);2
+ ELIF and7 = 1 THEN write ("CP"+modification);2
+ ELIF and7 = 2 THEN write ("IN"+modification);2
+ ELSE write ("??? $ED "+hex(next byte));2
+ FI
+ ELSE write ("??? $ED "+hex(next byte));2
+ FI.
+
+is 40 to 7f :
+ div 10 < 8 AND div 10 > 3.
+
+modification :
+ SELECT div8 OF
+ CASE 0 : "I"
+ CASE 1 : "D"
+ CASE 2 : "IR"
+ CASE 3 : "DR"
+ OTHERWISE "???"
+ ENDSELECT.
+
+ENDPROC calculate ed instruction;
+
+ENDPACKET z80 disassembler
+
|