From 98cab31fc3659e33aef260efca55bf9f1753164c Mon Sep 17 00:00:00 2001 From: Lars-Dominik Braun Date: Mon, 11 Feb 2019 11:49:19 +0100 Subject: Add source files from Michael --- devel/debugger/doc/DEBUGGER.PRT | 2021 ++++++++++++++++++++++ devel/debugger/src/DEBUGGER.ELA | 3151 +++++++++++++++++++++++++++++++++++ devel/misc/unknown/src/0DISASS.ELA | 1110 ++++++++++++ devel/misc/unknown/src/ASSEMBLE.ELA | 387 +++++ devel/misc/unknown/src/COPYDS.ELA | 294 ++++ devel/misc/unknown/src/DS4.ELA | 268 +++ devel/misc/unknown/src/PRIVS.ELA | 485 ++++++ devel/misc/unknown/src/TABINFO.ELA | 117 ++ devel/misc/unknown/src/TRACE.ELA | 552 ++++++ devel/misc/unknown/src/XLIST.ELA | 143 ++ devel/misc/unknown/src/XSTATUS.ELA | 188 +++ devel/misc/unknown/src/Z80.ELA | 495 ++++++ 12 files changed, 9211 insertions(+) create mode 100644 devel/debugger/doc/DEBUGGER.PRT create mode 100644 devel/debugger/src/DEBUGGER.ELA create mode 100644 devel/misc/unknown/src/0DISASS.ELA create mode 100644 devel/misc/unknown/src/ASSEMBLE.ELA create mode 100644 devel/misc/unknown/src/COPYDS.ELA create mode 100644 devel/misc/unknown/src/DS4.ELA create mode 100644 devel/misc/unknown/src/PRIVS.ELA create mode 100644 devel/misc/unknown/src/TABINFO.ELA create mode 100644 devel/misc/unknown/src/TRACE.ELA create mode 100644 devel/misc/unknown/src/XLIST.ELA create mode 100644 devel/misc/unknown/src/XSTATUS.ELA create mode 100644 devel/misc/unknown/src/Z80.ELA (limited to 'devel') diff --git a/devel/debugger/doc/DEBUGGER.PRT b/devel/debugger/doc/DEBUGGER.PRT new file mode 100644 index 0000000..4379f4a --- /dev/null +++ b/devel/debugger/doc/DEBUGGER.PRT @@ -0,0 +1,2021 @@ +*************************************************************************** +*** *** +*** D o k u m e n t a t i o n *** +*** zum EUMEL-Debugger *** +*** *** +*** Autor: Michael Staubermann *** +*** Stand der Dokumentation: 03.12.86 *** +*** Stand des Debuggers: 01.12.86 *** +*** *** +*************************************************************************** + +1. Anwendung des Debuggers +1.1 Code Disassembler (Decoder) +1.1.1 Datenrepr„sentation +1.1.2 Datenadressen +1.1.3 Codeadressen + +1.2 Ablaufverfolgung (Tracer) + +2. Die EUMEL0-Instruktionen +2.1 Erl„uterung der Instruktionen (Thematisch sortiert) +2.2 Alphabetische Liste der Instruktionen + +3. Beschreibung der Pakete +3.1 PACKET address +3.2 PACKET table routines +3.3 PACKET eumel decoder +3.4 PACKET tracer + +#page# +#ub#1. Anwendung des Debuggers#ue# + +Der EUMEL-Debugger ist fr die Software-Entwickler und nicht fr die +Anwender dieser Software gedacht. Insbesondere bei der Entwicklung +systemnaher Software, wie z.B. Compiler, ist der Debugger hilfreich. + +(ELAN-)Programme werden wie bisher compiliert (z.B. insertiert), ohne daá +der Quelltext des Programmes vorher modifiziert werden máte. Um den +Sourcetext w„hrend der Ablaufverfolgung (Trace) beobachten zu k”nnen, +máen die Programme mit 'check on' bersetzt werden. + +Die sinnvolle Anwendung des Debuggers setzt allerdings Kenntnis der +EUMEL0-Instruktionen voraus, die im Kapitel 2 erl„utert werden (Der Debugger +setzt die Codierung BIT-A fr diese Instruktionen voraus, d.h. er l„uft +zumindest in der interpretativen EUMEL0-Version.). + + +#ub#1.1 Code Disassembler (Decoder)#ue# + +Der Decoder konvertiert die vom Compiler erzeugte Bitcodierung (16 Bit) in +Mnemonics (Textdarstellung der Instruktionen), die in eine FILE geschrieben, +bzw. optional auf dem Bildschirm ausgegeben werden k”nnen. Die Bitcodierung +kann zus„tzlich ausgegeben werden. +Der Decoder wird mit 'decode' aufgerufen. W„hrend der Dekodierung stehen +folgende Tastenfunktionen zur Verfgung: + +Taste Funktion +----------------------------------------------------------------------- + ESC Abbruch der Dekodierung. + e Echo. Schaltet die parallel Bildschirmausgabe ein/aus. + l Zeilennummern statt Hexadezimaladressen mitprotokollieren. + a Hexadezimaladressen statt Zeilennummern mitprotokollieren. + f Zeigt den Namen und die aktuelle Zeilennummer der Protokollfile. + d getcommand ; docommand + s storage info + m Zeigt die aktuelle Modulnummer an (sinnvoll falls kein Echo) + Q,W Zeilennummern/Hexadressen mitprotokollieren (falls kein Echo) + S Keine Zeilennummern/Hexadressen ausgeben (l„uft auch im Hintergrund) + + +#ub#1.1.1 Datenrepr„sentation#ue# + +INT-Zahlen werden hexadezimal (xxxxH, xxH) oder dezimal dargestellt, +TEXTe in Anfhrungszeichen ("..."), +REALs im 20-Stellen scientific-Format, +TASK-Objekte durch XX-YYYY/"name" mit XX als Taskindex und YYYY als Version, + wenn die Stationsnummer nicht 0 ist, wird sie vor XX als SS- dargestellt. +DATASPACE-Objekte werden durch XX-YY repr„sentiert (XX ist der eigene + Taskindex, YY ist die Datenraumnummer), +BOOL-Objekte durch TRUE oder FALSE. +Module werden durch ihre Modulnummer, optional auch durch ihre + Startadresse, und falls m”glich durch ihren Namen repr„sentiert. Die + Parameterliste wird in den F„llen, wo das Modul in der Permanenttabelle + vermerkt ist auch angegeben. +Nicht weiter dereferenzierbare Adressen werden durch ein vorgestelltes '@' +gekennzeichnet (z.B. BOUND-Objekte). +In den F„llen, wo es mehrere sinnvolle Darstellungen gibt, werden diese +durch ein '|' getrennt. + + +#ub#1.1.2 Datenadressen#ue# + +Zus„tzlich zu den globalen Daten (statische Variablen und Denoter) kann auch +deren Adresse ausgegeben werden. Die Daten werden in einer, ihrem Typ +entsprechenden, Darstellung ausgegeben. Komplexe oder zusammengesetzte +Datentypen werden auf Repr„sentationen elementarer Datentypen (INT, REAL, +BOOL, TEXT, DATASPACE, TASK) abgebildet. + +Prozeduren, Operatoren und Paketinitialisierungen von Main-Packets werden +zusammenfassend als Module bezeichnet. Einem Modul geh”rt ein eigener +Stackbereich fr lokale Daten, Parameter und Rcksprungadresse etc. In +diesem Bereich stehen entweder die Datenobjekte selbst (z.B. lokale +Variablen) oder lokale Referenzadressen auf beliebige Objekte (lokale, +globale Daten, Fremddatenr„ume und sogar Module). +Da die effektiven lokalen Adressen erst w„hrend der Runtime bekannt sind, +findet man im Decoder-Output nur die Adressoffsets relativ zum Stackanfang +des Moduls. + +Datenadressen werden in spitzen Klammern angegeben, Branch-Codeaddressen ohne +Klammern. Alle Adressen sind Wortaddressen. Der Adresstyp wird durch einen +Buchstaben nach '<' angezeigt: +'G' kennzeichnet eine globale Adresse (Denoter oder statische Variable). Die +Representation der Daten kann immer angegeben werden (also nicht nur zur +Runtime). +'L' kennzeichnet einen Adressoffset fr ein lokales Datenobjekt auf dem +Stack. Da die lokale Basis, d.h. die Anfangsadresse der Daten des aktuellen +Moduls, erst bei Runtime feststehen, kann hier weder die effektive +Datenadresse, noch der Inhalt des Datenobjekts angegeben werden. +'LR' kennzeichnet eine lokale Referenzadresse, d.h. auf dem Stack steht +eine Adresse (32 Bit), die ein Datenobjekt adressiert. Žhnlich wie bei 'L' +kann auch bei 'LR' erst zur Runtime eine Representation des adressierten +Datenobjekts angegeben werden. Der Wert nach 'LR' bezeichnet den Offset, der +zur lokalen Basis addiert werden muá, um die Adresse der Referenzadresse zu +erhalten. Die niederwertigsten 16 Bit (das erste der beiden W”rter) k”nnen +128KB adressieren. Im h”herwertigsten Byte des zweiten Wortes steht die +Nummer des Datenraumes der eigenen Task, der das adressierte Datenobjekt +enth„lt (0 entspricht dem Standarddatenraum). Das niederwertigste Byte des +zweiten Wortes enth„lt die Segmentnummer (128KB-Segmente) mit dem +Wertebereich 0 bis 7 (maximal also 1MB/Datenraum). Im Standarddatenraum +(Datenraumnummer 4) enthalten die Segmente folgene Tabellen: + +Segment Tabelle +------------------------------------------------- + 0 Paketdaten (high 120KB) und Moduladresstabelle + 1 Stack (low 64K), Heap (high 64K) + 2 Codesegment + 3 Codesegment (120KB) u.a. fr eigene Module + 4 Compilertabellen tempor„r + 5 Compilertabellen permanent + 6 nilsegment fr Compiler (FF's) + 7 Compiler: Intermediate String + +Repr„sentationen von Datenobjekten, die in Fremddatenr„umen residieren +(BOUND-Objekte) k”nnen zur Zeit noch nicht ausgegeben werden, statt dessen +wird die Datenraumnummer und die Wortadresse innerhalb dieses Datenraums +ausgegeben. + + +#ub#1.1.3 Codeadressen#ue# + +Module werden in der Regel (Ausnahme: Parameterprozeduren) ber ihre +Modulnummer angesprochen, aus der dann die Adresse des Moduls berechnet +werden kann (mithilfe der Moduladresstabelle). Die Adressen der +Parameterprozeduren sind vom Typ 'LR' (Local-Reference), kommen nur als +Parameter auf dem Stack vor und beeinhalten Codesegment und Codeadresse. + +Sprungadressen (von Branch-Befehlen) adressieren immer nur das eigene +Segment und davon auch nur eine Adresse innerhalb eines 8 KB groáen +Bereichs. + + +#ub#1.2 Ablaufverfolgung (Tracer)#ue# + +Um den eigenen (!) Code im Einzelschrittbetrieb abzuarbeiten, wird der +Tracer benutzt. Auáer den Inhalten der globalen Daten kann man sich die +Inhalte der Stackobjekte (lokale Variablen) und der aktuellen Parameter +eines Prozeduraufrufs (auch von Parameterprozeduren) ansehen. Es k”nnen +keine Daten ver„ndert werden! +Man hat die M”glichkeit +- die Resultate der letzten ausgefhrten Instruktion oder +- die aktuellen Parameter fr den n„chsten Instruktionsaufruf +zu beobachten. +Der Inhalt des Stacks kann sequentiell durchgesehen werden, Error- und +Disablestop-Zustand k”nnen gel”scht werden. +Der Einzelschrittablauf kann protokolliert und die entsprechende +Sourceline parallel zum ausgefhrten Code beobachtet werden. +Der Einzelschrittbetrieb kann, ber Teile des Codes hinweg, ausgeschaltet +werden, z.B. fr h„ufig durchlaufene Schleifen. +Fr die Repr„sentation der Daten und deren Adressen gilt das unter 1.1 +gesagte. +Der Tracer wird mit 'trace' aufgerufen. W„hrend der Aktivit„t des Tracers +stehen folgende Funktionen zur Verfgung (Nur der erste Buchstabe wird +getippt): + +Abkrzung Funktion +-------------------------------------------------------------------------- + Auto Die Befehle werden im Einzelschrittbetrieb ausgefhrt, ohne daá + eine Taste gedrckt werden muá. + Bpnt Der n„chste Breakpoint wird an eine vom Benutzer festgelegte + Codeadrese gesetzt. Damit k”nnen Teile des Codes abgearbeitet + werden, ohne daá der Einzelschrittmodus aktiv ist. Nach der + Eingabe der Adresse wird der Befehl an dieser Adresse angezeigt. + Best„tigt wird die Richtigkeit mit oder 's'. + Clrr Ein eventuell vorliegender Fehlerzustand wird gel”scht. + Dstp 'disable stop' wird fr das untersuchte Modul gesetzt. + Estp 'enable stop' wird fr das untersuchte Modul gesetzt. + File Der Name der kompilierten Quelldatei wird eingestellt. + Go Der Code wird bis zum Ende abgearbeitet, ohne daá der Tracer + aktiviert wird. + Prot Der Name der Protokollfile wird eingestellt. Die abgearbeiteten + Instruktionen werden in dieser File protokolliert. + Rslt Es wird umgeschaltet, ob die angezeigte Instruktion nach + oder 's' abgearbeitet werden soll (Forward-Trace, 'F') oder ob das + Ergebnis der letzten ausgefhrten Instruktion angezeigt werden soll + (Result-Trace, 'R'). Der aktuelle Zustand dieses Switches wird in + der ersten Bildschirmzeile durch 'R' oder 'F' gekennzeichnet. + Kurzzeitige Umschaltung, um das Ergebnis der letzten Operation + anzusehen, ist auch m”glich (zweimal 'r' tippen). + Step/CR Mit oder 's' wird die n„chste Instruktion ausgefhrt. + Dies ist bei Forward-Trace die angezeigte Instruktion. + Term Bis zur n„chst 'h”heren' Prozedur der CALL-Sequence, die im + 'disable stop'-Zustand arbeitet, werden die Module verlassen. In + der Regel bedeutet dies ein Programmabbruch. Alle Breakpoints sind + anschlieáend zurckgesetzt. + - Der Stackpointer auf den sichtbaren Stack (in der ersten + Bildschirmzeile) wird um zwei verringert. Er zeigt auf die n„chst + tiefere Referenzadresse. Der EUMEL-0-Stackpointer wird nicht + ver„ndert. + + Der Stackpointer auf den sichtbaren Stack wird um zwei erh”ht. + < Bei der Befehlsausgabe werden die Parameteradressen zus„tzlich + ausgegeben (in spitzen Klammern). + > Bei der Befehlsausgabe werden keine Parameteradressen ausgegeben, + sondern nur die Darstellungen der Parameter (z.B. + Variableninhalte) + +#page# +#ub#2. EUMEL0-Instruktionen#ue# + + +#ub#2.1 Erl„uterung der Instruktionen (Thematisch sortiert)#ue# + +Nach der H„ufigkeit ihres Vorkommens im Code unterscheidet man 3 Klassen von +Instruktionen: 30 Prim„rbefehle, 6 Spezialbefehle und z.Zt. 127 +Sekund„rbefehle. +Die Prim„rbefehle enthalten im ersten Wort den Opcode (5 Bit) und 11 Bit fr +die erste Parameteradresse d.h. den Wertebereich 0..2047. Liegt die +Parameteradresse auáerhalb dieses Bereichs, dann ersetzt ein +Umschaltprefix (LONGAddress) die Opcodebits und im lowbyte des +ersten Wortes wird der Opcode codiert. Die erste Parameteradresse befindet +sich dann als 16 Bit-Wert im zweiten Wort. +Spezialbefehle enthalten im ersten Wort auáer dem Opcode (8 Bit) noch einen +8 Bit-Immediatewert (Bytekonstante). +Sekund„rebefehle enthalten im ersten Wort nur den Opcode (16 Bit), der aus +einem Umschaltprefix (ESCape, wird im folgenden weggelassen) und im lowbyte +dem 8 Bit Sekndaropcode besteht. + +Im folgenden werden Datenadressen mit 'd', Immediatewerte mit 'v' (Value), +Codeadressen mit 'a' und Modulnummern mit 'm' bezeichnet. Die Anzahl dieser +Buchstaben gibt die L„nge der ben”tigten Opcodebits (DIV 4) an. Ausnahmsweise +bezeichnet .nn:dd einen 5 Bit Opcode ('nn') und eine 11 Bit Adresse ('dd'). + +Der Adresstyp ist in den Bits 14 und 15 codiert: +15 14 Typ Effektive Adresse + 0 0 global dddd + pbase (pbase wird mit PENTER eingestellt) + 1 0 local (dddd AND 7FFF) DIV 2 + lbase (lbase wird beim CALL gesetzt) + 1 1 local ref adr := ((dddd AND 7FFF) DIV 2 + lbase) ; (adr+1, adr) + +Der Wert eines Wortes an der ersten Parameteradresse wird mit +bezeichnet. Ein Datentyp vor der spitzen Klammer gibt seinen Typ an. Fr die +anderen Parameter gilt entsprechendes (, , ...). + + +#ub#2.1.1 Datentransportbefehle#ue# + +MOV .08:dd dddd 1 Wort (z.B. INT/BOOL) wird von der linken + Adresse zur rechten Adresse transportiert. + := + +FMOV .34:dd dddd 4 W”rter (z.B. REAL) von linker Adresse zur + rechten Adresse tranportieren (kopiert). + := + +TMOV .4C:dd dddd Kopiert einen Text von der linken Adresse zur + rechten Adresse. + TEXT := TEXT + +MOVi FC vv dddd Die Konstante vv (1 Byte) wird als positive + 16 Bit-Zahl dem Wort an der Adresse dddd + zugewiesen. + := vv + +MOVii 7F 23 vvvv dddd Dem Wort an der Adresse dddd wird die 16-Bit + Konstante vvvv zugewiesen. + := vvvv + +MOVx 7D vv dddd dddd Von der linken Adresse zur rechten Adresse + werden vv (max. 255) W”rter transportiert. + := (vv W”rter) + +MOVxx 7F 21 vvvv dddd dddd Von der linken Adresse zur rechten Adresse + werden vvvv (max. 65535) W”rter transportiert. + := (vvvv W”rter) + + +#ub#2.1.2 INT-Operationen#ue# + +ARITHS 7F 5B Schaltet um auf vorzeichenbehaftete + INT-Arithmetik (Normalfall). + ARITH := Signed + +ARITHU 7F 5C Schaltet um auf vorzeichenlose 16Bit-Arithmetik + (Compiler). + ARITH := Unsigned + +CLEAR .24:dd Dem Wort an der Adresse dd wird 0 zugewiesen. + := 0 + +INC1 .0C:dd Der Inhalt des Wortes an der Adresse dddd wird + um eins erh”ht. + := + 1 + +DEC1 .10:dd Der Inhalt des Wortes an der Adresse dddd wird + um eins verringert. + := - 1 + +INC .14:dd dddd Der Inhalt des Wortes an der ersten Adresse wird + zum Inhalt des Wortes an der zweiten Adresse + addiert. + := + + +DEC .18:dd dddd Der Inhalt des Wortes an der ersten Adresse wird + vom Inhalt des Wortes an der zweiten Adresse + subtrahiert. + := - + +ADD .1C:dd dddd dddd Der Inhalt der Worte der beiden ersten + Adressen wird addiert und bei der dritten + Adresse abgelegt. + := + + +SUB .20:dd dddd dddd Der Inhalt des Wortes an der zweiten Adresse + wird vom Inhalt des Wortes an der ersten Adresse + subtrahiert und das Resultat im Wort an der + dritten Adresse abgelegt. + := - + +MUL 7F 29 dddd dddd dddd Der Wert der W”rter an den beiden ersten + Adressen wird vorzeichenbehaftet multipliziert + und im Wort an der dritten Adresse abgelegt. + Ein šberlauf wird im Falle der vorzeichenlosen + Arithmetik ignoriert ( MOD 65536). + := * + +IMULT 7F 28 dddd dddd dddd Der Wert der W”rter an den beiden ersten + Adressen wird vorzeichenlos multipliziert und + im Wort an der dritten Adresse abgelegt. + Falls das Resultat ein Wert gr”áer 65535 w„re, + wird := FFFFH, sonst + := * + +DIV 7F 2A dddd dddd dddd Der Wert des Wortes an der ersten Adresse wird + durch den Wert des Wortes an der zweiten + Adresse dividiert und im Wort an der dritten + Adresse abgelegt. Eine Division durch 0 fhrt + zum Fehler. + := DIV + +MOD 7F 2B dddd dddd dddd Der Rest der Division (wie bei DIV) wird im + Wort an der dritten Adresse abgelegt. Falls + = 0 ist, wird ein Fehler ausgel”st. + := MOD + +NEG 7F 27 dddd Der Wert des Wortes an der Adresse dddd wird + arithmetisch negiert (Vorzeichenwechsel). + := - + +AND 7F 7C dddd dddd dddd Der Wert der beiden W”rter an den beiden ersten + Adressen wird bitweise UND-verknpft und das + Resultat im Wort an der dritten Adresse + abgelegt. + := AND + +OR 7F 7D dddd dddd dddd Der Wert der beiden W”rter an den beiden ersten + Adressen wird bitweise ODER-verknpft und das + Resultat im Wort an der dritten Adresse + abgelegt. + := OR + +XOR 7F 79 dddd dddd dddd Der Wert der beiden W”rter an den beiden ersten + Adressen wird bitweise Exklusiv-ODER-verknpft + und das Resultat im Wort an der dritten Adresse + abgelegt. + := XOR + +ROTATE 7F 53 dddd dddd Der Wert an der ersten Adresse wird um soviele + Bits links oder rechts rotiert, wie es der Wert + des zweiten Parameters angibt (positiv = + links). + IF < 0 + THEN := ROR + ELSE := ROL + FI + + +#ub#2.1.3 REAL-Operationen#ue# + +FADD .38:dd dddd dddd Die beiden ersten REAL-Werte werden addiert und + das Resultat an der dritten Adresse abgelegt. + REAL := REAL + REAL + +FSUB .3C:dd dddd dddd Der zweite REAL-Wert wird vom ersten + subtrahiert und das Resultat an der dritten + Adresse abgelegt. + REAL := REAL + REAL + +FMUL .40:dd dddd dddd Die beiden ersten REAL-Werte werden + multipliziert und das Resultat an der dritten + Adresse abgelegt. + REAL := REAL * REAL + +FDIV .44:dd dddd dddd Der erste REAL-Wert wird durch den zweiten + dividiert und das Resultat an der dritten + Adresse abgelegt. + REAL := REAL / REAL + +FNEG 7F 26 dddd Das Vorzeichen des REAL-Wertes an der Adresse + dddd wird gewechselt. + REAL := -REAL + +FSLD 7F 60 dddd dddd dddd Die Mantisse des REAL-Wertes an der zweiten + Adresse wird um ein Digit (4 Bit BCD) nach + links verschoben, Vorzeichen und Exponent + bleiben unver„ndert. Das vorher h”herwertigste + Digit steht danach im Wort an der dritten + Adresse. Das neue niederwertigste Digit wurde + aus dem Wort der ersten Adresse entnommen. + INT := digit1 ; + REAL := REAL SLD 1 ; + digit13 := INT<ÿ1> + +GEXP 7F 61 dddd dddd Der Exponent des REAL-Wertes an der ersten + Adresse wird in das Wort an der zweiten Adresse + gebracht. + INT := exp + +SEXP 7F 62 dddd dddd Der Wert des Wortes an der ersten Adresse wird + in den Exponenten des REAL-Wertes an der zweiten + Adresse gebracht. + exp := INT + +FLOOR 7F 63 dddd dddd Der REAL-Wert an der ersten Adresse wird ohne + Dezimalstellen an der zweiten Adresse abgelegt. + := floor + + +#ub#2.1.4 TEXT-Operationen#ue# + +ITSUB 7F 2D dddd dddd dddd Aus dem TEXT an der ersten Adresse wird das + Wort, dessen Position durch das Wort an der + zweiten Adresse beschrieben wird, im Wort an + der dritten Adresse abgelegt. + INT := TEXT[INT,2] (Notation: + t[n,s] bezeichnet das n. Element mit einer + Gr”áe von s Bytes, der Bytekette t an der + Byteposition n*s+1) + +ITRPL 7F 2E dddd dddd dddd In dem TEXT an der ersten Adresse wird das + Wort, dessen Position durch das Wort an der + zweiten Adresse beschrieben wird, durch das Wort + an der dritten Adresse ersetzt. + TEXT[INT,2] := INT + +DECOD 7F 2F dddd dddd Der dezimale ASCII-Wert des Zeichens im TEXT an + der ersten Adresse wird im Wort an der zweiten + Adresse abgelegt. + INT := code (TEXT) + +ENCOD 7F 30 dddd dddd Dem der TEXT an der zweiten Adresse wird ein + Zeichen zugewiesen, das dem ASCII-Wert im Wort + an der ersten Adresse entspricht. + TEXT := code (INT) + +SUBT1 7F 31 dddd dddd dddd Dem TEXT an der dritten Adresse wird das + Zeichen des TEXTes an der ersten Adresse + zugewiesen, dessen Position durch das Wort an + der zweiten Adresse bestimmt ist. + TEXT := TEXT[INT, 1] + +SUBTFT 7F 32 dddd dddd dddd dddd Dem TEXT an der vierten Adresse wird ein + Teiltext des TEXTes an der ersten Adresse + zugewiesen, dessen Startposition im Wort an der + zweiten Adresse steht und dessen Endposition im + Wort an der dritten Adresse steht. + TEXT := subtext (TEXT, INT, INT) + +SUBTF 7F 33 dddd dddd dddd Dem TEXT an der dritten Adresse wird ein + Teiltext des TEXTes an der ersten Adresse + zugewiesen, der an der durch das Wort an der + zweiten Adresse beschriebenen Position beginnt + und bis zum Ende des Sourcetextes geht. + TEXT := subtext (TEXT, INT, length + (TEXT)) + +REPLAC 7F 34 dddd dddd dddd Der TEXT an der ersten Adresse wird ab der + Position, die durch das Wort an der zweiten + Position bestimmt wird, durch den TEXT an der + dritten Adresse ersetzt. + replace (TEXT, INT, TEXT) + +CAT 7F 35 dddd dddd Der TEXT an der zweiten Adresse wird an das + Ende des TEXTes an der ersten Adresse angefgt. + TEXT := TEXT + TEXT + +TLEN 7F 36 dddd dddd Die L„nge des TEXTes an der ersten Adresse wird + im Wort an der zweiten Adresse abgelegt. + INT := length (TEXT) + +POS 7F 37 dddd dddd dddd Die Position des ersten Auftretens des TEXTes + an der zweiten Adresse, innerhalb des TEXTes an + der ersten Adresse, wird im Wort an der dritten + Adresse abgelegt. + INT := pos (TEXT, TEXT, 1, length + (TEXT)) + +POSF 7F 38 dddd dddd dddd dddd + Die Position des ersten Auftretens des TEXTes + an der zweiten Adresse, innerhalb des TEXTes an + der ersten Adresse, ab der Position die durch + den Inhalt des Wortes an der dritten Adresse + bestimmt ist, wird im Wort an der vierten + Adresse abgelegt. + INT := pos (TEXT, TEXT, INT, + length (TEXT)) + +POSFT 7F 39 dddd dddd dddd dddd dddd + Die Position des ersten Auftretens des TEXTes + an der zweiten Adresse, innerhalb des TEXTes an + der ersten Adresse, ab der Position die durch + den Inhalt des Wortes an der dritten Adresse + bestimmt ist, bis zur Position die durch den + Inhalt des Wortes an der vierten Adresse + bestimmt ist, wird im Wort an der fnften + Adresse abgelegt. + INT := pos (TEXT, TEXT, INT, + INT) + +STRANL 7F 3A dddd dddd dddd dddd dddd dddd dddd + (ROW 256 INT CONST, INT VAR, INT CONST, + TEXT CONST, INT VAR, INT CONST, INT VAR): + Vereinfachte funktionsweise: + extension := FALSE ; + FOR INT FROM INT UPTO min (INT, + length (TEXT)) WHILE INT < INT + REP + IF extension + THEN extension := FALSE + ELSE INT:=ROW[TEXT[INT,1]]; + IF INT < 0 + THEN extension := TRUE ; + INT INCR (INT-8000H) + ELSE INT INCR INT + FI + FI + PER + +POSIF 7F 3B dddd dddd dddd dddd dddd + Die Position des ersten Auftretens des, durch + die beiden Zeichen des TEXTes an der zweiten + und dritten Adresse begrenzten ASCII-Bereichs + (lowchar, highchar), Zeichens innerhalb des + TEXTes an der ersten Adresse, wird ab der + Position, die durch das Wort an der vierten + Adresse beschrieben wird, im Wort an der + fnften Adresse abgelegt. + INT := pos (TEXT, TEXT, TEXT, + INT). + +GARB 7F 5F Es wird eine Garbagecollection fr den + taskeigenen TEXT-Heap durchgefhrt. + +HPSIZE 7F 5E dddd Die aktuelle Gr”áe des TEXT-Heaps wird in dem + Wort an der Adresse dddd abgelegt. + := heapsize + +RTSUB 7F 64 dddd dddd dddd Aus dem TEXT an der ersten Adresse wird der + REAL-Wert, dessen Position durch das Wort an + der zweiten Adresse beschrieben wird, an der + dritten Adresse abgelegt. + REAL := TEXT[INT, 8] + +RTRPL 7F 65 dddd dddd dddd In dem TEXT an der ersten Adresse wird der + REAL-Wert, dessen Position durch das Wort an der + zweiten Adresse beschrieben wird, durch den + REAL-Wert an der dritten Adresse ersetzt. + TEXT[INT, 8] := REAL + + +#ub#2.1.5 DATASPACE-Operationen#ue# + +DSACC .58:dd dddd Die dsid an der ersten Adresse wird auf + Gltigkeit geprft und an der zweiten Adresse + eine Referenzaddresse abgelegt, die auf das + 4. Wort des Datenraumes (den Anfang des + Datenbereichs) zeigt. + IF valid ds (DS) + THEN REF := DATASPACE.ds base + ELSE "falscher DATASPACE-Zugriff" + FI + +ALIAS 7F 22 vvvv dddd dddd Dem BOUND-Objekt an der dritten Adresse wird + der Datenraum an der zweiten Adresse zugewiesen + (INT-Move). Zuvor wird geprft, ob dies der + erste Zugriff auf den Datenraum ist. Falls ja, + wird der Datenraumtyp auf 0 gesetzt. Falls ein + Heap aufgebaut werden muá und noch keiner + angelegt wurde, wird die Anfangsadresse des + Heaps auf den Wert vvvv+4 innerhalb des + Datenraumes gesetzt. + IF DATASPACE.typ < 0 + THEN DATASPACE.typ := 0 + FI ; + IF DATASPACE.heapanfang < 0 + THEN DATASPACE.heapanfang := vvvv+4 + FI ; + INT := INT + +NILDS 7F 45 dddd Dem Datenraum an der Adresse dddd wird der + 'nilspace' zugewiesen. + INT := 0 + +DSCOPY 7F 46 dddd dddd Dem Datenraum an der ersten Adresse wird eine + Kopie des Datenraumes an der zweiten Adresse + zugewiesen (neue dsid). Es wird ein neuer + Eintrag in die Datenraumverwaltung aufgenommen. + DATASPACE := DATASPACE + +DSFORG 7F 47 dddd Der Datenraum, dessen dsid an der Adresse dddd + steht, wird aus der Datenraumverwaltung + gel”scht. + forget (DATASPACE) + +DSWTYP 7F 48 dddd dddd Der Typ des Datenraums, dessen dsid an der + ersten Adresse steht, wird auf den Wert des + Wortes an der zweiten Adresse gesetzt. + DATASPACE.typ := INT ; + IF DATASPACE.heapanfang < 0 + THEN DATASPACE.heapanfang := vvvv+4 + FI + +DSRTYP 7F 49 dddd dddd Der Typ des Datenraums, dessen dsid an der + ersten Adresse steht, wird in dem Wort an der + zweiten Adresse abgelegt. + INT := DATASPACE.typ ; + IF DATASPACE.heapanfang < 0 + THEN DATASPACE.heapanfang := vvvv+4 + FI + +DSHEAP 7F 4A dddd dddd Die Endaddresse Textheaps des Datenraums, dessen + dsid an der ersten Adresse steht, in 1kB + Einehiten, wird in dem Wort an der zweiten + Adresse abgelegt. Falls dieser Wert = 1023 oder + < 96 ist, ist kein Heap vorhanden, anderenfalls + ist seine Gr”áe (in KB): -96. + INT := DATASPACE.heapende DIV 1024 + +NXTDSP 7F 4B dddd dddd dddd Fr den Datenraum an der ersten Adresse wird + die Nummer der Seite, die auf die Nummer der + Seite folgt, die in dem Wort an der zweiten Adresse + steht an der zweiten Adresse abgelegt. Falls + keine Seite mehr folt, wird -1 geliefert. + INT := nextdspage (DATASPACE, INT) + +DSPAGS 7F 4C dddd dddd dddd Fr den Datenraum mit der Nummer, die im Wort + an der ersten Adresse steht, und der Task deren + Nummer im Wort an der zweiten Adresse steht, + wird die Anzahl der belegten Seiten im Wort an + der dritten Adresse abgelegt. + INT := ds pages (INT, INT) + +SEND 7F 71 dddd dddd dddd dddd + Der Datenraum an der dritten Adresse wird der + Task, deren id an der ersten Adresse steht, mit + dem Messagecode der an der zweiten Adresse + steht, gesendet. Der Antwortcode wird im Wort + an der vierten Adresse abgelegt. Vereinfachte + Semantik: + send (TASK, INT, DATASPACE, INT) + +WAIT 7F 72 dddd dddd dddd Die eigene Task geht in einen offenen + Wartezustand, bei dem sie empfangsbereit ist fr + einen Datenraum einer anderen Task. Die id der + sendenden Task wird an der ersten Adresse + abgelegt, der Messagecode an der zweiten + Adresse, der gesendete Datenraum an der dritten + Adresse. Vereinfachte Semantik: + wait (TASK, INT, DATASPACE) + +SWCALL 7F 73 dddd dddd dddd dddd + Der Datenraum an der dritten Adresse wird der + Task, deren id an der ersten Adresse steht, mit + dem Messagecode der an der zweiten Adresse + steht, gesendet bis die Task empfangsbereit ist. + Dann wird auf einen zurckgesandten Datenraum + dieser Task gewartet, der an der dritten + Adresse abgelegt wird. Der zurckgesendete + Messagecode wird an der vierten Adresse + abgelegt. Vereinfachte Semantik: + REP + send (TASK, INT, DATASPACE,INT) + UNTIL INT <> task busy PER ; + wait (TASK, INT, DATASPACE) + +PPCALL 7F 7A dddd dddd dddd dddd + Wirkt wie SWCALL, wartet aber nicht bis die + Zieltask empfangsbereit ist, sondern liefert -2 + an der vierten Adresse zurck, wenn die Task + nicht empfangsbereit ist. Vereinfachte + Semantik: + send (TASK, INT, DATASPACE,INT); + IF INT <> task busy + THEN wait (TASK, INT, DATASPACE) + FI + +SENDFT 7F 7F dddd dddd dddd dddd dddd + Der Datenraum an der vierten Adresse wird der + Task, deren id an der zweiten Adresse steht, + mit dem Messagecode der an der dritten Adresse + steht, gesendet als ob er von der Task k„me, + deren id an der ersten Adresse steht. Der + Antwortcode wird im Wort an der vierten + Adresse abgelegt. Dieser Befehl setzt eine + Priviligierung >= 1 voraus und ist nur wirksam, + wenn die from-Task einer anderen Station + angeh”rt. Vereinfachte Semantik: + IF station (TASK) = station (myself) + THEN send (TASK, INT, DATASPACE, + INT) + ELSE save myself := myself ; + myself := TASK ; + send (TASK, INT, DATASPACE, + INT) ; + myself := save myself + FI + + +#ub#2.1.6 TASK-Operationen#ue# + +TWCPU 7F 52 dddd dddd Die CPU-Zeit der Task, deren Nummer an der + ersten Adresse steht, wird auf den REAL-Wert, + der an der zweiten Adresse steht gesetzt. Dieser + Befehl setzt eine Privilegierung > 1 voraus + (Supervisor). + pcb(INT).clock := REAL + +TPBEGIN 7F 5F dddd dddd dddd aaaaaa + Als Sohn der Task, deren Nummer an der ersten + Adresse steht, wird eine Task eingerichtet, + deren Nummer an der zweiten Adresse steht. Die + neue Task erh„lt die Privilegierung, deren + Nummer in dem Wort an der dritten Adresse + steht und wird mit der Prozedur gestartet, + deren Code bei der durch den vierten Parameter + bergebenen Refereznadresse beginnt. Dieser + Befehl setzt eine Privilegierung > 1 voraus + (Supervisor). + +TRPCB 7F 68 dddd dddd dddd Der Wert des Leitblockfeldes der Task + deren Nummer an der ersten Adresse steht und + der Nummer, die in dem Wort an der zweiten + Adresse steht, wird an der dritten Adresse + abgelegt. + INT := pcb(INT, INT) + +TWPCB 7F 69 dddd dddd dddd Der Wert an der dritten Adresse wird in das + Leitblockfeld mit der Nummer an der zweiten + Adresse der Task bertragen, deren Nummer an der + ersten Adresse steht. Privilegierung: + 0: Nur linenumber-Feld (0), der eigenen Task + 1: linenumber-Feld der eigenen Task und + prio-Feld (5) jeder Task + 2: Alle Felder + Fr den Fall, daá die Privilegierung ok ist + gilt: + pcb (INT, INT) := INT + +TCPU 7F 6A dddd dddd Die CPU-Zeit der Task, deren Nummer an der + ersten Adresse steht, wird als REAL-Wert an der + zweiten Adresse abgelegt. + REAL := pcb (INT).clock + +TSTAT 7F 6B dddd dddd Der Status (busy, i/o, wait) der Task, deren + Nummer an der ersten Adresse steht, wird im Wort + an der zweiten Adresse abgelegt. + INT := pcb (INT).status + +ACT 7F 6C dddd Die Task mit der Nummer, die an der Adresse dddd + steht wird aktiviert (entblockt). Dieser Befehl + setzt eine Privilegierung >= 1 voraus. + activate (INT) + +DEACT 7F 6D dddd Die Task, deren Nummer an der Adresse dddd + steht, wird deaktiviert (geblockt). Dieser + Befehl setzt eine Privilegierung >= 1 voraus. + deactivate (INT) + +THALT 7F 6E dddd In der Task, deren Nummer an der Adresse dddd + steht, wird ein Fehler 'halt vom Terminal' + induziert. Dieser Befehl setzt eine + Privilegierung > 1 voraus (Supervisor). + halt process (INT) + +TBEGIN 7F 6F dddd aaaaaa Eine neue Task wird eingerichtet, deren Nummer + an der ersten Adresse steht. Die Adresse der + Startprozedur wird als Referenzadresse im + zweiten Parameter bergeben. Der Datenraum 4 + wird von der aufrufenden Task geerbt. Als + Privilegierung wird 0 eingetragen. + Dieser Befehl setzt eine Privilegierung > 1 + voraus (Supervisor). + +TEND 7F 70 dddd Die Task, deren Nummer an der Adresse dddd + steht, wird gel”scht (alle Datenr„ume) und aus + der Prozessverwaltung entfernt. Dieser Befehl + setzt eine Privilegierung > 1 voraus + (Supervisor). + +PNACT 7F 76 dddd Die Nummer der n„chsten aktivierten Task + wird aus der Aktivierungstabelle gelesen. Die + Suche beginnt mit dem Wert+1 an der Adresse. Die + Nummer n„chsten aktivierten Task wird an dieser + Adresse abgelegt. + INT := next active (INT) + +DEFCOL 7F 80 dddd Die Task an der Adresse wird als Collectortask + (fr Datenaustausch zwischen Stationen) + definiert. Dieser Befehl setzt eine + Privilegierung >= 1 voraus. + TASK collector := TASK + + +#ub#2.1.7 Tests und Vergleiche#ue# + +Alle Tests und Vergleiche liefern ein BOOL-Resultat, welches den Opcode des +nachfolgenden Branch-Befehls bestimmt (Aus LN wird BT aus BR wird BF). + +TEST .28:dd Liefert TRUE, wenn das Wort an der Adresse 0 + ist (Auch fr BOOL-Variablen gebraucht: TRUE=0, + FALSE=1). + FLAG := = 0 + +EQU .2C:dd dddd Liefert TRUE, wenn die W”rter der beiden + Adressen gleich sind. + FLAG := = + +LSEQ .30:dd dddd Liefert TRUE, wenn der Wert des Wortes an der + ersten Adresse (vorzeichenbehaftet) kleiner oder + gleich dem Wert des Wortes an der zweiten + Adresse ist. + FLAG := INT <= INT + +FLSEQ .48:dd dddd Liefert TRUE, wenn der REAL-Wert an der ersten + Adresse kleiner oder gleich dem REAL-Wert an der + zweiten Adresse ist. + FLAG := REAL <= REAL + +FEQU 7F 24 dddd dddd Liefert TRUE, wenn der REAL-Wert an der ersten + Adresse gleich dem REAL-Wert an der zweiten + Adresse ist. + FLAG := REAL = REAL + +TLSEQ 7F 25 dddd dddd Liefert TRUE, wenn der TEXT an der ersten + Adresse kleiner oder gleich dem TEXT an der + zweiten Adresse ist. + FLAG := TEXT <= TEXT + +TEQU .50:dd dddd Liefert TRUE, wenn der TEXT an der ersten + Adresse gleich dem TEXT an der zweiten Adresse + ist. + FLAG := TEXT = TEXT + +ULSEQ .54:dd dddd Liefert TRUE, wenn der Wert des Wortes an der + ersten Adresse (vorzeichenlos) kleiner oder + gleich dem Wert des Wortes an der zweiten + Adresse ist. + FLAG := INT "<=" INT + +EQUIM 7C vv dddd Liefert TRUE, wenn der Wert des Wortes an der + Adresse dddd gleich der 8 Bit Konstanten vv + ist. + FLAG := INT = vv + +ISDIG 7F 12 dddd Liefert TRUE, wenn der ASCII-Code im Wort an + der Adresse dddd einer Ziffer entspricht. + FLAG := INT >= 48 AND INT <= 57 + +ISLD 7F 13 dddd Liefert TRUE, wenn der ASCII-Code im Wort an + der Adresse dddd einer Ziffer oder einem + Kleinbuchstaben entspricht. + FLAG := INT >= 48 AND INT <= 57 OR + INT >= 97 AND INT <= 122 + +ISLCAS 7F 14 dddd Liefert TRUE, wenn der ASCII-Code im Wort an + der Adresse dddd einem Kleinbuchstaben + entspricht. + FLAG := INT >= 97 AND INT <= 122 + +ISUCAS 7F 15 dddd Liefert TRUE, wenn der ASCII-Code im Wort an + der Adresse dddd einem Groábuchstaben + entspricht. + FLAG := INT >= 65 AND INT <= 90 + +ISSHA 7F 18 dddd Liefert TRUE, wenn der Wert des Wortes an der + Adresse dddd im Bereich 0..2047 liegt, d.h. + eine Kurzadresse ist, die noch zusammen mit dem + Opcode im ersten Wort eines Prim„rbefehls + untergebracht werden kann. + FLAG := INT < 2048 + +ISERR 7F 4E Liefert TRUE, wenn ein Fehlerzustand vorliegt. + FLAG := ERROR + +EXTASK 7F 7B dddd Liefert TRUE, wenn die Task, deren id an der + Adresse dddd steht, existiert (nicht "dead" und + korrekte Versionsnummer). + FLAG := TASK.version = + pcb (TASK.nr).version AND + pcb (TASK.nr).status <> dead + + +#ub#2.1.8 I/O-Operationen#ue# + +OUT 7F 3C dddd Der Text an der Adresse wird ausgegeben. + out (TEXT) + +COUT 7F 3D dddd Falls der Kanal frei ist und die INT-Zahl an + der Adresse dddd positiv ist, wird sie als + Dezimalzahl ausgegeben. + IF free (channel) + THEN out (text (INT, 5) + 5 * ""8"") + FI + +OUTF 7F 3E dddd dddd Der Text an der ersten Adresse wird ab der + Position, die durch den Wert des Wortes an der + zweiten Adresse bestimmt wird, bis zum Ende + ausgegeben. + out (subtext (TEXT, INT, length + (TEXT))) + +OUTFT 7F 3F dddd dddd dddd Der Text an der ersten Adresse wird ab der + Position, die durch den Wert an der zweiten + Adresse bestimmt wird, bis zur Position die + durch den Wert an der dritten Adresse bestimmt + wird, ausgegeben. + out (subtext (TEXT, INT, INT)) + +INCHAR 7F 40 dddd Es wird auf ein Eingabezeichen gewartet, + welches dann im TEXT an der Adresse dddd + abgelegt wird. + IF zeichen da (channel) + THEN TEXT := incharety + ELSE offener wartezustand (inchar) ; + TEXT := incharety + FI + +INCETY 7F 41 dddd Falls kein Eingabezeichen vorhanden ist, wird + im TEXT an der Adresse dddd niltext geliefert, + sonst das Eingabezeichen. + IF zeichen da (channel) + THEN TEXT := incharety + ELSE TEXT := "" + FI + +PAUSE 7F 42 dddd Der Wert an der Adresse dddd bestimmt die + Wartezeit in Zehntelsekunden, die gewartet + werden soll. Die Pause kann durch eine Eingabe + auf dem Kanal abgebrochen werden. + IF NOT zeichen da (channel) + THEN modi := INT ; + offener wartezustand (pause) + FI + +GCPOS 7F 43 dddd dddd Die Cursorposition wird erfragt. Die x-Position + wird an der ersten Adresse abgelegt, die + y-Position an der zweiten Adresse. + getcursor (INT, INT) + +CATINP 7F 44 dddd dddd Aus dem Eingabepuffer werden alle Zeichen + gelesen und an den TEXT an der ersten Adresse + geh„ngt, bis entweder der Eingabepuffer leer + ist oder ein Zeichen mit einem Code < 32 + gefunden wurde. Im ersten Fall wird niltext an + der zweiten Adresse abgelegt, im zweiten Fall + das Trennzeichen. + REP + IF zeichen da (channel) + THEN zeichen := incharety ; + IF code (zeichen) < 32 + THEN TEXT := zeichen + ELSE TEXT CAT zeichen + FI + ELSE TEXT := "" ; + LEAVE CATINP + FI + PER + +CONTRL 7F 54 dddd dddd dddd dddd + Der IO-Controlfunktion mit der Nummer, die + an der ersten Adresse steht, werden die beiden + Parameter bergeben, die an der zweiten und + dritten Adresse stehen. Die Rckmeldung wird + an der vierten Adresse abgelegt. + IF channel > 0 + THEN iocontrol (INT, INT, INT, + INT) + FI + +BLKOUT 7F 55 dddd dddd dddd dddd dddd + Die Seite des Datenraums, dessen dsid an der + ersten Adresse steht, mit der Seitennummer, die + an der zweiten Adresse steht, wird auf dem + aktuellen Kanal ausgegeben. Als Parameter + werden die Werte an der dritten und vierten + Adresse bergeben. Der Returncode wird an der + fnften Adresse abgelegt. + IF channel > 0 + THEN blockout (DATASPACE[INT, 512], + INT, INT, INT) + FI + +BLKIN 7F 56 dddd dddd dddd dddd dddd + Die Seite des Datenraums, dessen dsid an der + ersten Adresse steht, mit der Seitennummer, die + an der zweiten Adresse steht, wird an dem + aktuellen Kanal eingelesen. Als Parameter + werden die Werte an der dritten und vierten + Adresse bergeben. Der Returncode wird an der + fnften Adresse abgelegt. + IF channel > 0 + THEN blockout (DATASPACE[INT, 512], + INT, INT, INT) + FI + + +#ub#2.1.9 Ablaufsteuerung (Branch und Gosub)#ue# + +B .70:aa bzw. .74:aa Unbedingter Sprung an die Adresse. + ICOUNT := aaaa (aaaa gilt nur fr den + Debugger/Tracer, da die Adressrechung intern + komplizierter ist) + +BF .70:aa bzw. .74:aa Wenn der letzte Befehl FALSE lieferte, Sprung an + die Adresse. + IF NOT FLAG + THEN ICOUNT := aaaa (aaaa s.o.) + FI + +BT .00:aa bzw. .04:aa Wenn der letzte Befehl TRUE lieferte, Sprung an + die Adresse (auch LN-Opcode). + IF FLAG + THEN ICOUNT := aaaa (aaaa s.o.) + FI + +BRCOMP 7F 20 dddd vvvv Wenn das Wort an der Adresse dddd kleiner als 0 + oder gr”áer als die Konstante vvvv ist, wird mit + dem auf den BRCOMP-Befehl folgenden Befehl + (i.d.R. ein B-Befehl) fortgefahren. Sonst wird + die Ausfhrung an der Adresse des + BRCOMP-Befehls + 2 + (dddd) (auch ein B-Befehl) + fortgesetzt. + IF >= 0 AND <= vvvv + THEN ICOUNT INCR ( + 1) + FI + +GOSUB 7F 05 aaaa Die aktuelle Codeadresse wird auf den Stack + gebracht und das Programm an der Adresse aaaa + fortgesetzt. + :=(LBASE, PBASE, ICOUNT, ENSTOP, ARITH) ; + LBASE := TOP ; + ICOUNT := aaaa ; + CMOD := high (ICOUNT) + 16 + +GORET 7F 07 Das Programm wird an der oben auf dem Stack + stehenden Returnadresse fortgesetzt. + TOP := LBASE ; + SP := TOP + 4 ; + (LBASE, PBASE, ICOUNT, ENSTOP, ARITH) := + + +#ub#2.1.10 Modul-Operationen#ue# + +PPV .68:dd Das Wort an der Adresse wird auf den Stack + gebracht. Dieser Befehl wird vom Compiler nicht + generiert. + := INT ; + SP INCR 2 + +PP .6C:dd Die Referenzadresse des Objektes wird auf den + Stack gebracht (2 Worte). + := REF d1 ; + SP INCR 2 + +PPROC 7F 1E mmmm Die Adresse der Prozedur mit der Modulnummer + mmmm wird als Referenzadresse (Codesegment, + Codeadresse) auf den Stack gebracht. + := mod addr (mmmm) ; + SP INCR 2 + +HEAD vvvv (kein Opcode) Der Speicherplatz fr lokale Variablen und + Parameter in diesem Modul wird vermerkt, indem + der Stacktop um vvvv erhoht wird. + TOP INCR vvvv ; + SP := TOP + 4 + +PENTER FE vv Die Paketbasis (Basis der globalen Adressen + dieses Moduls) wird auf den Wert vv*256 + gesetzt. + PBASE := vv * 256 + +CALL .78:mm Das Modul mit der Nummer mm wird aufgerufen. + :=(LBASE, PBASE, ICOUNT, ENSTOP, ARITH) ; + LBASE := TOP ; + ICOUNT := mod addr (mm) ; + CMOD := high (ICOUNT) + 16 + +PCALL 7F 1F dddd Die (Parameter-)Prozedur, deren Startadresse + als Referenzadresse auf dem Stack steht, wird + aufgerufen. + :=(LBASE, PBASE, ICOUNT, ENSTOP, ARITH) ; + LBASE := TOP ; + ICOUNT := d1 ; + CMOD := high (ICOUNT) + 16 . + +EXEC 7F 1D dddd Das Modul dessen Nummer in dem Wort an der + Adresse dddd steht, wird aufgerufen. + :=(LBASE, PBASE, ICOUNT, ENSTOP, ARITH) ; + LBASE := TOP ; + ICOUNT := ; + CMOD := high (ICOUNT) + 16 . + +RTN 7F 00 Das Modul wird verlassen, die + Programmausfhrung setzt an der, auf dem Stack + gesicherten, Adresse fort. + TOP := LBASE ; + SP := TOP + 4 ; + (LBASE, PBASE, ICOUNT, ENSTOP, ARITH) := + +RTNT 7F 01 Das Modul wird verlassen und der BOOL-Wert TRUE + geliefert (fr den dem CALL/PCALL folgenden + BT/BF-Befehl). Die Programmausfhrung setzt an + der, auf dem Stack gesicherten, Adresse fort. + TOP := LBASE ; + SP := TOP + 4 ; + (LBASE, PBASE, ICOUNT, ENSTOP, ARITH) := ; + FLAG := TRUE + +RTNF 7F 02 Das Modul wird verlassen und der BOOL-Wert + FALSE geliefert (fr den dem CALL/PCALL + folgenden BT/BF-Befehl). Die Programmausfhrung setzt an + der, auf dem Stack gesicherten, Adresse fort. + TOP := LBASE ; + SP := TOP + 4 ; + (LBASE, PBASE, ICOUNT, ENSTOP, ARITH) := ; + FLAG := FALSE + + +#ub#2.1.10 Datenadressrechnung#ue# + +REF .5C:dd dddd An der zweiten Adresse wird die Referenzadresse + der ersten Adresse abgelegt (2 W”rt-MOV). + REF := d1 + +SUBS .60:vv vvvv dddd dddd dddd + Wenn der Inhalt des Wortes an der dritten + Adresse (ROW-Index) gr”áer oder gleich der + Konstanten vvvv (limit-1) ist, wird "Subscript + šberlauf" gemeldet, falls der ROW-Index kleiner + als eins ist wird "Subscript šnterlauf" + gemeldet. Andernfalls wird der um eins + verringerte ROW-Index mit der Konstanten vv + (Size eines ROW-Elements) multipliziert, + zur Basisaddresse (vierter Parameter) addiert + und als Referenzadresse an der fnften Adresse + abgelegt. + IF INT <= vvvv AND INT > 0 + THEN REF := d2 + vv * (INT-1) + ELSE "Fehler" s.o. + FI + +SEL .64:dd vvvv dddd Die Konstante vvvv (Selektor-Offset einer + STRUCT) wird zur Adresse dd addiert und als + Referenzadresse auf dem Stack an der Adresse + dddd abgelegt. + REF := vv + d1 + +CTT 7F 0C dddd dddd Die Adresse des Strings(!) an der ersten + Adresse wird an der zweiten Adresse als + Referenzadresse (Segment 0, DS 4) abgelegt. + CTT steht fr Compiler-Table-Text. + REF := REF (0004, INT) + + +#ub#2.1.12 Compiler-Spezialbefehle#ue# + +PUTW FD v1v2 dddd dddd Das lowbyte des Opcode besteht aus den beiden + Nibbles v1 (Segment) und v2 (Wordoffset). Das + Wort an der zweiten dddd-Adresse wird an die + Adresse im Datenraum 4, Segment v1 geschrieben, + die durch den Wert des Wortes an der ersten + dddd-Adresse + v2 bestimmt ist. + + v2> := INT + +GETW 7E v1v2 dddd dddd Das lowbyte des Opcode besteht aus den beiden + Nibble v1 (Segment) und v2 (Wordoffset). Das + Wort im Datenraum 4, Segment v1 an der durch + den Wert des Wortes an der ersten dddd-Adresse + + v2 bestimmten Adresse wird an der zweiten + dddd-Adresse abgelegt. + INT := + v2) + +PW 7F 6F dddd dddd dddd Das Wort an der dritten Adresse wird im + Datenraum 4 an die Adresse geschrieben, die + durch das Segment (erste Adresse) und die + Adresse in diesem Segment (zweite Adresse) + bestimmt ist. + * 64KW + INT> := INT + +GW 7F 70 dddd dddd dddd Das Wort im Datenraum 4, das durch das Segment + (erste Adresse) und die Adresse in diesem + Segment (zweite Adresse) bestimmt ist, wird an + der dritte Adresse abgelegt. + INT := * 64KW + INT> + +BCRD 7F 08 dddd dddd Bereitet das Lesen einzelner Zeichen aus dem + Segment 4 des Datenraumes 4 vor (Nametable). + Das Wort an der ersten Adresse enth„lt die + Startadresse des Strings und zeigt auf das + L„ngenbyte. Nach dem Ausfhren des Befehls + enth„lt das Wort an der zweiten Adresse das + L„ngenbyte und der Pointer an der ersten + Adresse zeigt auf das erste Zeichen des Textes. + Das Bit 15 des Pointers ist gesetzt, wenn das + highbyte adressiert wird. + INT := length (STRING) ; + INT INCR 1/2 + +CRD 7F 09 dddd dddd Liest ein Zeichen aus dem String, dessen Lesen + mit BCRD vorbereitet wurde. Die erste Adresse + enth„lt einen Stringpointer, der nach jedem + Lesen erh”ht wird, die zweite Adresse enth„lt + nach dem Aufruf des Befehls den Code des + gelesenen Zeichens. + INT := code (STRING) ; + INT INCR 1/2 + +CWR 7F 0B dddd dddd dddd Der Hashcode an der ersten Adresse wird mit dem + zu schreibenden Zeichencode (dritte Adresse) + verknpft und in den Bereich 0..1023 gemapt. + Das Zeichen wird an die Position des Pointers + geschrieben (Bit 15 des Pointers unterscheidet + lowbyte und highbyte). Anschlieáend wird der + Pointer auf die Adresse des n„chsten Zeichens + gesetzt. Der Pointer steht an der zweiten + Adresse. Vor dem Schreiben des ersten Zeichens + muá der Hashcode auf 0 gesetzt werden. + INT INCR INT ; + IF INT > 1023 THEN INT DECR 1023 FI ; + INT := (INT + INT) MOD 1024 ; + STRING> := code (INT) ; + INT INCR 1/2 + +ECWR 7F 0A dddd dddd dddd Das Schreiben eines Strings wird beendet. Dazu + wird an der ersten Adresse der Stringpointer + bergegeben, an der zweiten Adresse wird die + endgltige Stringl„nge geliefert. An der + dritten Adresse wird die Adresse des n„chsten + freien Platzes nach diesem Stringende + geliefert. + +GETC 7F 0D dddd dddd dddd Dieser Befehl liefert ein BOOL-Result und zwar + TRUE, wenn das Wort an der zweiten Adresse + gr”áer als 0 und kleiner als die L„nge des + TEXTes an der ersten Adresse ist. In diesem Fall + wird im Wort an der dritten Adresse der Code + des n. Zeichens des TEXTes geliefert. Die + Position des Zeichens wird durch das Wort an + der zweiten Adresse bestimmt. + FLAG := INT > 0 AND INT <= length + (TEXT) ; + INT := code (TEXT[INT, 1]) + +FNONBL 7F 0E dddd dddd dddd Dieser Befehl liefert ein BOOL-Result. + zaehler := INT ; (* Stringpointer *) + WHILE TEXT[zahler, 1] = " " REP + zaehler INCR 1 + PER ; + IF zaehler > length (TEXT) + THEN FLAG := FALSE + ELSE INT := code (TEXT[zaehler, 1]); + INT := zaehler + 1 + FI + +DREM256 7F 0F dddd dddd Das lowbyte des Wortes an der ersten Adresse + wird in das Wort an der zweiten Adresse + geschrieben, das highbyte des Wortes an der + ersten Adresse ersetzt das gesamte erste Wort. + INT := INT MOD 256 ; + INT := INT DIV 256 + +AMUL256 7F 10 dddd dddd Umkerung von DREM256. + INT := INT * 256 + INT + +GADDR 7F 16 dddd dddd dddd "Adresswort" mit Adresstyp generieren (z.B. + = pbase). + IF INT >= 0 (* Global *) + THEN INT := INT - INT + ELIF bit (INT, 14) (* Local Ref *) + THEN INT := (INT AND 3FFFH)*2 + 1 + ELSE INT := (INT AND 3FFFH)*2 + (* Local *) + FI + +GCADDR 7F 17 dddd dddd dddd Diese Instruktion liefert ein BOOL-Result. + Mit = 0 wird sie eingesetzt, um die + Zeilennummer im LN-Befehl zu generieren, mit + <> 0 wird sie eingesetzt, um die Adresse im + Branchbefehl zu generieren. Beide Befehle gibt + es mit zwei Opcodes (00/04 bzw. 70/74). + byte := high(INT)-high(INT) ; + IF byte < 0 + THEN byte INCR 16 ; (* Bit fr LN1 bzw. B1 + Opcode *) + rotate (byte, right) ; + FI ; + INT := byte * 256 + low (INT) ; + FALSE, wenn irgendeins der Bits 11..14 = 1 ist + +GETTAB 7F 1A Kopiert den Inhalt der unteren 64KB des + Segments 5 im DS 4 in das Segment 4. + (permanentes Segment --> tempor„res Segment) + DS4: 50000..57FFF --> 40000..47FFF (Wortaddr) + +PUTTAB 7F 1B Kopiert den Inhalt der unteren 64KB des Segments + 4 im DS 4 in das Segment 5. (Tempor„re Daten + werden permanent) + DS4: 40000..47FFF --> 50000..57FFF (Wortaddr) + +ERTAB 7F 1C Kopiert den Inhalt des Segments 6 im DS 4 + (besteht nur aus FF's) in die Segmente 4 und 7, + d.h. das tempor„re Segment (u.a. Symboltabelle) + und das Segment mit Compiler-Intermediatestring + werden gel”scht. + DS4: 60000..6FDFF --> 40000..4FDFF ; + DS4: 60000..6FDFF --> 70000..7FDFF + +CDBINT 7F 74 dddd dddd Das Wort mit der Nummer wird aus dem + Segment 5 gelesen und in abgelegt. + INT := <50000H + INT> + +CDBTXT 7F 74 dddd dddd Der String(!) an der Adresse im Segment 5 + wird in dem TEXT abgelegt. + TEXT := ctt (<50000H + INT>) + + +#ub#2.1.13 Instruktionen zur Programmsteuerung#ue# + +STOP 7F 04 Alle (aufrufenden) Module werden verlassen, bis + das erste im 'disablestop'-Zustand angetroffen + wird (Žhnlich errorstop ("")) ; + WHILE ENSTOP REP return PER . + + return: + TOP := LBASE ; + SP := TOP + 4 ; + (LBASE, PBASE, ICOUNT, ENSTOP, ARITH) := + +ESTOP 7F 4B Der 'enable stop'-Zustand wird eingeschaltet. + ENSTOP := TRUE + +DSTOP 7F 4C Der 'disable stop'-Zustand wird eingeschaltet. + ENSTOP := FALSE + +SETERR 7F 4D dddd Es wird der Fehlerzustand eingeschaltet, das + Wort an der Adresse dddd wird in das pcb-Feld + 'error code' gebracht. Falls das Modul im + 'enablestop'-Zustand ist, wird das Modul + verlassen. + IF NOT ERROR + THEN ERROR := TRUE ; + pcb.error line := pcb.line ; + pcb.error code := INT ; + WHILE ENSTOP REP return PER + FI + +CLRERR 7F 4F Falls der Fehlerzustand vorliegt, wird der + Fehler gel”scht. + ERROR := FALSE + +LN .00:vv und .04:vv Die Konstante vv wird in das pcb-Feld + 'line number' gebracht (Zur Fehlerbehandlung). + pcb.line := vv + +RPCB 7F 50 dddd dddd Der Inhalt des pcb-Feldes der eigenen Task mit + der Nummer, die im Wort an der ersten Adresse + steht, wird in das Wort an der zweiten Adresse + gebracht. + INT := pcb (myself, INT[) + +CLOCK 7F 66 dddd dddd Die Systemuhr mit der Nummer, die durch den + Wert des Wortes an der ersten Adresse + spezifiziert wird, wird gelesen und deren + REAL-Wert an der zweiten Adresse abgelegt. + Wenn = 0 ist, wird die CPU-Zeit der + eigenen Task geliefert, anderenfalls die + Systemuhr mit der Nummer 1..7 : + Nummer Funktion + 1 REAL-Time + 2 Paging Wait + 3 Paging Busy + 4 Foreground Tasks cpu-time + 5 Background Tasks cpu-time + 6 System cpu-time + 7 Reserviert + + IF INT = 0 + THEN REAL := pcb.clock + ELSE REAL := clock (INT) + FI + + +#ub#2.1.14 Systemglobale Instruktionen#ue# + +KE 7F 06 Der EUMEL0-Debugger 'Info' wird aufgerufen, + falls dies ein infof„higes System ist. + +SYSG 7F 19 Sysgen (Nur beim Sysgen-Urlader). + +INFOPW 7F 51 dddd dddd dddd Das bis zu 10 Zeichen lange Infopassword an der + zweiten Adresse (TEXT) wird eingestellt, falls + das alte Infopassword mit dem TEXT an der + ersten Adresse bereinstimmt. In diesem Fall + wird im Wort an der dritten Adresse eine 0 + abgelegt, andernfalls eine 1. Dies ist kein + privilegierter Befehl, er funktioniert + allerdings nur, wenn das alte Infopasswort + bekannt ist. + IF info password = TEXT + THEN info password := TEXT ; + INT := 0 + ELSE INT := 1 + FI + +STORAGE 7F 5A dddd dddd Die Gr”áe des vorhandene Hintergrundspeichers + in KB wird im Wort an der ersten Adresse + abgelegt, die Gr”áe des benutzten + Hintergrundspeichers an der zweiten Adresse. + INT := size ; + INT := used + +SYSOP 7F 5B dddd Es wird eine Systemoperation mit der Nummer, + die an der Adresse dddd steht, aufgerufen + (1=Garbage Collection, 11=Savesystem, 4=Shutup, + 2=Fixpoint). Dieser Befehl setzt eine + Privilegierung >= 1 voraus. + +SETNOW 7F 67 dddd Die Realtime-Clock (clock(1)) des Systems wird + auf den REAL-Wert an der Adresse dddd gesetzt. + Dieser Befehl setzt eine Privilegierung >= 1 + voraus. + clock (1) := REAL + +SESSION 7F 7E dddd Der aktuelle Wert des Systemlaufz„hlers wird + an der Adresse dddd abgelegt. + INT := systemlaufzaehler + +ID 7F 81 dddd dddd Der Wert des id-Feldes mit der Nummer, die an + der ersten Adresse steht, wird in das Wort an + der zweiten Adresse geschrieben. Fr dei + Nummern der id-Felder gilt: + Feld Inhalt + 0 Kleinste HG-Version fr EUMEL0 + 1 CPU-Type (1=Z80,3=8086,4=68000,5=80286) + 2 Urlader-Version + 3 Reserviert + 4 Lizenznummer des Shards + 5 Installationsnummer + 6 Frei fr Shard + 7 Frei fr Shard + IF INT < 4 + THEN INT := eumel0 id (INT) + ELSE INT := shard id (INT) + FI + + +#ub#2.1 Alphabetische Liste der Befehle#ue# + +ACT 7F 6C dddd +ADD .1C:dd dddd dddd +ALIAS 7F 22 vvvv dddd dddd +AMUL256 7F 10 dddd dddd +AND 7F 7C dddd dddd dddd +ARITHS 7F 5B +ARITHU 7F 5C +B .70:aa bzw. .74:aa +BCRD 7F 08 dddd dddd +BF .70:aa bzw. .74:aa +BLKIN 7F 56 dddd dddd dddd dddd dddd +BLKOUT 7F 55 dddd dddd dddd dddd dddd +BRCOMP 7F 20 dddd vvvv +BT .00:aa bzw. .04:aa +CALL .78:mm +CAT 7F 35 dddd dddd +CATINP 7F 44 dddd dddd +CDBINT 7F 74 dddd dddd +CDBTXT 7F 74 dddd dddd +CLEAR .24:dd +CLOCK 7F 66 dddd dddd +CLRERR 7F 4F +CONTRL 7F 54 dddd dddd dddd dddd +COUT 7F 3D dddd +CRD 7F 09 dddd dddd +CTT 7F 0C dddd dddd +CWR 7F 0B dddd dddd dddd +DEACT 7F 6D dddd +DEC .18:dd dddd +DEC1 .10:dd +DECOD 7F 2F dddd dddd +DEFCOL 7F 80 dddd +DIV 7F 2A dddd dddd dddd +DREM256 7F 0F dddd dddd +DSACC .58:dd dddd +DSCOPY 7F 46 dddd dddd +DSFORG 7F 47 dddd +DSHEAP 7F 4A dddd dddd +DSPAGS 7F 4C dddd dddd dddd +DSRTYP 7F 49 dddd dddd +DSTOP 7F 4C +DSWTYP 7F 48 dddd dddd +ECWR 7F 0A dddd dddd dddd +ENCOD 7F 30 dddd dddd +EQU .2C:dd dddd +EQUIM 7C vv dddd +ERTAB 7F 1C +ESTOP 7F 4B +EXEC 7F 1D dddd +EXTASK 7F 7B dddd +FADD .38:dd dddd dddd +FDIV .44:dd dddd dddd +FEQU 7F 24 dddd dddd +FLOOR 7F 63 dddd dddd +FLSEQ .48:dd dddd +FMOV .34:dd dddd +FMUL .40:dd dddd dddd +FNEG 7F 26 dddd +FNONBL 7F 0E dddd dddd dddd +FSLD 7F 60 dddd dddd dddd +FSUB .3C:dd dddd dddd +GADDR 7F 16 dddd dddd dddd +GARB 7F 5F +GCADDR 7F 17 dddd dddd dddd +GCPOS 7F 43 dddd dddd +GETC 7F 0D dddd dddd dddd +GETTAB 7F 1A +GETW 7E v1v2 dddd dddd +GEXP 7F 61 dddd dddd +GORET 7F 07 +GOSUB 7F 05 aaaa +GW 7F 70 dddd dddd dddd +HEAD vvvv (kein Opcode) +HPSIZE 7F 5E dddd +ID 7F 81 dddd dddd +IMULT 7F 28 dddd dddd dddd +INC .14:dd dddd +INC1 .0C:dd +INCETY 7F 41 dddd +INCHAR 7F 40 dddd +INFOPW 7F 51 dddd dddd dddd +ISDIG 7F 11 dddd +ISERR 7F 4E +ISLCAS 7F 13 dddd +ISLD 7F 12 dddd +ISSHA 7F 18 dddd +ISUCAS 7F 14 dddd +ITRPL 7F 2E dddd dddd dddd +ITSUB 7F 2D dddd dddd dddd +KE 7F 06 +LN .00:vv und .04:vv +LSEQ .30:dd dddd +MOD 7F 2B dddd dddd dddd +MOV .08:dd dddd +MOVi FC vv dddd +MOVii 7F 23 vvvv dddd +MOVx 7D vv dddd dddd +MOVxx 7F 21 vvvv dddd dddd +MUL 7F 29 dddd dddd dddd +NEG 7F 27 dddd +NILDS 7F 45 dddd +NXTDSP 7F 4B dddd dddd dddd +OR 7F 7D dddd dddd dddd +OUT 7F 3C dddd +OUTF 7F 3E dddd dddd +OUTFT 7F 3F dddd dddd dddd +PAUSE 7F 42 dddd +PCALL 7F 1F dddd +PENTER FE vv +PNACT 7F 76 dddd +POS 7F 37 dddd dddd dddd +POSF 7F 38 dddd dddd dddd dddd +POSFT 7F 39 dddd dddd dddd dddd dddd +POSIF 7F 3B dddd dddd dddd dddd dddd +PP .6C:dd +PPCALL 7F 7A dddd dddd dddd dddd +PPROC 7F 1E mmmm +PPV .68:dd +PUTTAB 7F 1B +PUTW FD v1v2 dddd dddd +PW 7F 6F dddd dddd dddd +REF .5C:dd dddd +REPLAC 7F 34 dddd dddd dddd +ROTATE 7F 53 dddd dddd +RPCB 7F 50 dddd dddd +RTN 7F 00 +RTNF 7F 02 +RTNT 7F 01 +RTRPL 7F 65 dddd dddd dddd +RTSUB 7F 64 dddd dddd dddd +SEL .64:dd vvvv dddd +SEND 7F 71 dddd dddd dddd dddd +SENDFT 7F 7F dddd dddd dddd dddd dddd +SESSION 7F 7E dddd +SETERR 7F 4D dddd +SETNOW 7F 67 dddd +SEXP 7F 62 dddd dddd +STOP 7F 04 +STORAGE 7F 5A dddd dddd +STRANL 7F 3A dddd dddd dddd dddd dddd dddd dddd +SUB .20:dd dddd dddd +SUBS .60:vv vvvv dddd dddd dddd +SUBT1 7F 31 dddd dddd dddd +SUBTF 7F 33 dddd dddd dddd +SUBTFT 7F 32 dddd dddd dddd dddd +SWCALL 7F 73 dddd dddd dddd dddd +SYSG 7F 19 +SYSOP 7F 5B dddd +TBEGIN 7F 6F dddd aaaaaa +TCPU 7F 6A dddd dddd +TEND 7F 70 dddd +TEQU .50:dd dddd +TEST .28:dd +THALT 7F 6E dddd +TLEN 7F 36 dddd dddd +TLSEQ 7F 25 dddd dddd +TMOV .4C:dd dddd +TPBEGIN 7F 5F dddd dddd dddd aaaaaa +TRPCB 7F 68 dddd dddd dddd +TSTAT 7F 6B dddd dddd +TWCPU 7F 52 dddd dddd +TWPCB 7F 69 dddd dddd dddd +ULSEQ .54:dd dddd +WAIT 7F 72 dddd dddd dddd +XOR 7F 79 dddd dddd dddd + +#page# +#ub#3. Beschreibung der Pakete#ue# + +#ub#3.1 PACKET address#ue# + +Mit diesem Paket werden die Operationen fr 16 Bit Adressrechnung zur +Verfgung gestellt. + +TEXT PROC hex8 (INT CONST dez) : + Der INT-Parameter (0..255) wird in eine 2-Zeichen Hexdarstellung + konvertiert. + + +TEXT PROC hex16 (INT CONST dez) : + Der INT-Parameter (0..65535) wird in eine 4-Zeichen + Hexdarstellung (ohne Vorzeichen) konvertiert. + + +INT PROC integer (TEXT CONST hex) : + Der TEXT-Parameter (1-4 Byte Hexdarstellung, 0..9, a..f/A..F) wird in eine + Dezimalzahl konvertiert. + + +INT PROC getword (INT CONST segment, address) : + Das Wort an der Adresse 'address' (0..65535) im Segment 'segment' (0..7) + wird gelesen. + + +PROC putword (INT CONST segment, address, value) : + Der Wert 'value' wird in das Wort an der Adresse 'address' (0..65535) im + Segment 'segment' (0..7) geschrieben. + + +INT PROC cdbint (INT CONST address) : + Der Wert an der Adresse 'address' (0..32767 sinnvoll) im Segment 5 + (permanente Compilertabellen) wird gelesen. + + +TEXT PROC cdbtext (INT CONST address) : + Der String, der an der Adresse 'address' im Segment 5 (permanente + Compilertabellen) beginnt, wird als TEXT gelesen. + + +PROC splitword (INT VAR word, lowbyte) : + Das Wort 'word' wird in den h”herwertigen und niederwertigen Teil zerlegt. + Das highbyte steht nach dieser Operation in 'word', das lowbyte in + 'lowbyte'. + + +PROC makeword (INT VAR word, INT CONST lowbyte) : + word := word * 256 + lowbyte + + +BOOL PROC ulseq (INT CONST left, right) : + '<=' fr positive INT-Zahlen (0..65535). + + +OP INC (INT VAR word) : + 'word INCR 1' fr positive INT-Zahlen (0..65535), ohne daá ein šberlauf + auftritt. + + +OP DEC (INT VAR word) : + 'word DECR 1' fr poistive INT-Zahlen (0..65535), ohne daá ein Unterlauf + auftritt. + + +INT OP ADD (INT CONST left, right) : + 'left + right' fr positive INT-Zahlen (0..65535), ohne daá ein šberlauf + auftritt. + + +INT OP SUB (INT CONST left, right) : + 'left - right' fr positive INT-Zahlen (0..65535), ohne daá ein šberlauf + auftritt. + + +INT OP MUL (INT CONST left, right) : + 'left * right' fr positive INT-Zahlen (0..65535), ohne daá ein šberlauf + auftritt. + + +#ub#3.2 PACKET table routines#ue# + +PROC init module table (TEXT CONST name) : + Ein benannter Datenraum ('name') wird eingerichtet. Dieser enth„lt die + aufbereitete Permanenttabelle fr schnelle Zugriffe. Die Datenstruktur + beschreibt drei Tabellen (PACKETTABLE, MODULETABLE, TYPETABLE), ber die + zu einer Modulnummer deren Name und deren Parameter, sowie der zugeh”rige + Paketname gefunden werden kann, wenn sie in der Permanenttabelle steht. + Die TYPETABLE enth„lt zu jedem TYPE, der in der Permanenttabelle steht, + seine Gr”áe in Words. + + +PROC add modules : + Module und Typen neu insertierter Pakete werden in die 'module table' + aufgenommen. + + +PROC dump tables (TEXT CONST name) : + Der Inhalt der geladenen Modultabelle wird in der FILE 'name' ausgedumpt. + + +TEXT PROC module name and specifications (INT CONST module number) : + Der Name und die Parameter des Moduls mit der Nummer 'module number' + (0..2047) wird als TEXT geliefert. Falls das Modul nicht in der + Permanenttabelle steht, wird niltext geliefert. + + +TEXT PROC packetname (INT CONST module number) : + Der Name des Pakets, das das Modul mit der Nummer 'module number' + definiert, wird als TEXT geliefert. Falls das Modul nicht in der + Permanenttabelle steht, wird der Name des letzten vorher insertierten + Pakets geliefert (In manchen F„llen also nicht der wahre Paketname). + + +INT PROC storage (TEXT CONST typename) : + Aus der Modultabelle wird Gr”áe des TYPEs mit dem Namen 'typname' gelesen. + Wenn der Typ nicht in der Permanenttabelle steht, wird 0 geliefert. + + +PROC getmodulenumber (INT VAR module number) : + Erfragt eine Modulnummer am Bildschirm. Der Benutzer kann entweder eine + Zahl eingeben oder den Namen einer PROC/OP. Wenn mehrere Module mit diesem + Namen existieren, wird eine Auswahlliste angeboten. In 'module number' + wird die ausgew„hlte Modulnummer bergeben. + + +INT PROC codeaddress (INT CONST module number) : + Liefert die Anfangsadresse des Moduls mit der Nummer 'module number'. + + +INT PROC codesegment (INT CONST module number) : + Liefert die Nummer des Codesegments, in dem der Code des Moduls mit der + Nummer 'module number' steht. + + +INT PROC hash (TEXT CONST object name) : + Berechnet den Hashcode des Objekts 'object name', um ber die Hashtable, + Nametable, Permanenttable die Parameter eines Objekts zu suchen. + + +#ub#3.3 PACKET eumel decoder#ue# + +#ub#3.3.1 Zugriff auf globale Parameter#ue# + +PROC default no runtime : + Bereitet den Decoder darauf vor, daá keine runtime vorliegt, d.h. + Stackzugriffe nicht sinnvoll sind. Fr Parameter mit lokalen Adressen + werden deshalb keine Variableninhalte dargestellt. Bei fast allen + Decoderaufrufen mit 'decode'/'decode module' bis auf die 'decode' mit + mehr als zwei Parametern, wird 'default no runtime' automatisch aufgerufen. + + +PROC set parameters (INT CONST lbase, pbase, line number, c8k) : +PROC get parameters (INT VAR lbase, pbase, line number, c8k) : + Einstell- und Informationsprozeduren (fr den Tracer). 'lbase' ist die + lokale Basis (Stackoffset fr dies Modul), 'pbase' ist das highbyte der + Paketbasis, 'line number' ist die letzte 'LN'-Zeilennummer, 'c8k' (cmod) + wird von EUMEL0 beim Eintritt in ein Modul auf + high (Modulstartaddresse + 16KB) gesetzt (fr Branch-Befehle). + + +PROC pbase (INT CONST pbase highbyte) : +INT PROC pbase : + Einstell- und Informationsprozeduren, nicht nur fr den Tracer. Die + Paketbasis (Globale Daten) wird gesetzt. Dazu wird nur das Highbyte (z.B. + nach 'PENTER') bergeben. + + +PROC lbase (INT CONST local base) : + Einstellprozedur fr den Tracer. Stellt w„hrend der runtime die aktuelle + Basis ein. Wird der Decoder nicht w„hrend runtime betrieben, sollte + lbase(-1) eingestellt werden. + + +INT PROC line number : + Liefert die letzte, mit 'LN' eingestellte, Zeilennummer. + +PROC list filename (TEXT CONST name) : + Stellt den Namens-Prefix der Outputfiles ein. Voreingestellt ist "". An + den Filename wird ".n" angeh„ngt, wobei n mit '0' beginnt. + +PROC bool result (BOOL CONST status) : +BOOL PROC bool result : + Einstell- und Informationsprozeduren, die fr den Tracer ben”tigt werden. + Lieferte der letzte disassemblierte Befehl ein BOOL-Result ? + +PROC with object address (BOOL CONST status) : +BOOL with object address : + Einstell- und Informationsprozeduren, nicht nur fr den Tracer. Sollen + auáer den Darstellungen der Speicherinhalte auch die Parameteradressen (in + spitzen Klammern) ausgegeben werden ? + +PROC with code words (BOOL CONST status) : +BOOL PROC with code words : + Einstell- und Informationsprozeduren, nicht fr den Tracer. Sollen ab der + 80. Spalte in der Outputfile die Hexdarstellungen der dekodierten + Codew”rter ausgegeben werden ? + + +#ub#3.3.2 Aufruf des Disassemblers#ue# + +PROC decode : + Aufruf des Decoders. Die Modulnummer der ersten zu dekodierenden Prozedur + wird erfragt. Die Modultabelle wird ggf. erg„nzt, es wird 'default no + runtime' eingestellt. + + +PROC decode (INT CONST first module number) : + Aufruf des Decoders. Die Modulnummer der ersten zu dekodierenden Prozedur + wird bergeben. Die Modultabelle wird ggf. erg„nzt, es wird 'default no + runtime' eingestellt. + + +PROC decode (INT CONST segment, address) : + Aufruf des Decoders. Die Disassemblierung beginnt in dem + Codesegment/Adresse, das/die als Parameter bergeben wird. Die Modultabelle + wird ggf. erg„nzt, es wird 'default no runtime' eingestellt. + + +PROC decode (INT CONST segment, INT VAR address, INT CONST to addr, + BOOL CONST only one module) : + Dieser Decoderaufruf setzt kein 'default no runtime', erweitert aber ggf. + die Modultabelle. Der bei 'address' beginnende und bei 'to addr' endende + Adressbereich im Codesegment 'segment' wird dekodiert. Ist 'only one + module' TRUE, wird nur bis zum Ende des aktuellen Moduls dekodiert. + 'address' zeigt nach dem Prozeduraufruf auf die n„chste Instruktion nach + 'to addr'. + + +PROC decode (INT CONST segment, INT VAR address, TEXT VAR words, + instruction, INT PROC (INT CONST, INT VAR, TEXT VAR) next word)): + Diese Prozedur ist das Herz des Decoders. Sie disassembliert eine + Instruktion, die im Codesegment 'segment', Adresse 'address' beginnt und + legt die mit 'nextword' gelesenen W”rter als Hexdarstellung in 'words' ab. + Die dekodierte Instruktion steht dann in 'instruction'. Vor dem Aufruf + dieser Prozedur sollte 'words' und 'instruction' niltext zugewiesen werden. + Die passende Prozedur 'nextword' wird auch vom 'eumel decoder' + herausgereicht. 'address' zeigt nach der Ausfhrung des Befehls auf die + n„chste Instruktion. + + +PROC decodemodule : + Wie 'decode', nur wird bis nur zum Ende des gewnschten Moduls + disassembliert. + + +PROC decodemodule (INT CONST module number) : + Wie 'decode', nur wird bis nur zum Ende des gewnschten Moduls + disassembliert. + + +#ub#3.3.3 Weitere Prozeduren#ue# + +PROC nextmoduleheader (INT CONST segment, INT CONST address, + INT VAR header address, module number) : + Diese Prozedur findet ab der angegeben Adresse ('segment'/'address') den + Anfang des n„chsten Moduls. In 'header address' wird die Startadresse des + gefundenen Moduls geliefert (bleibt im Segment 'segment'), in 'module + number' die Nummer des gefundenen Moduls. + + +INT PROC next word (INT CONST segment, INT VAR address, TEXT VAR words) : + Diese Prozedur liefert das durch 'segment'/'address' angegeben Wort, h„ngt + die Hexdarstellung dieses Wortes an 'words' an und erh”ht 'address' um + eins. + + +TEXT PROC data representation (INT CONST data addr, segment, address, type): + Diese Prozedur liefert die Darstellung des Parameters 'data addr' ggf. mit + Adresse (--> with object address). 'segment'/'address' bezeichnet die + Position, an der die Instruktion fr diesen Parameter steht. 'type' ist + ein (durch die Instruktion festgelegter) Typ des Parameters, mit dem die + Art der Darstellung gew„hlt wird (TEXT, REAL, INT, ...). Im Gegensatz zu + 'object representation' braucht bei dieser Prozedur keine Darstellung + vorhanden sein. In diesem Falle wird nur z.B. der Stackoffset '' + ausgegeben. + + +TEXT PROC object representation (INT CONST data segment, data address, + segment, address, type) : + Diese Prozedur wird von 'data representation' aufgerufen und liefert die + Darstellung des Parameters. In 'data segment'/'data address' wird die + Anfangsadresse der darzustellenden Daten bergeben. Die anderen drei + Parameter verhalten sich wie bei 'data representation'. + + +TEXT PROC last actual parameter : + Liefert den Wert (nach TEXT konvertiert) des letzten dekodierten aktuellen + Parameters (am sinnvollsten w„hrend runtime). Diese prozedur wird vom + Tracer benutzt. + + +#ub#3.4 PACKET tracer#ue# + +#ub#3.4.1 Zugriff auf globale Parameter#ue# + + +PROC prot file (TEXT CONST filename) : +TEXT PROC prot file : + Einstell- und Informationsprozeduren fr den Namen der Protokollfile. + Wird ein 'filename' ungleich niltext eingestellt, dann werden die + dekodierten Instruktionen w„hrend der Ablaufverfolgung zus„tzlich in diese + File geschrieben. + + +PROC source file (TEXT CONST filename) : +TEXT PROC source file : + Einstell- und Informationsprozeduren fr den Namen der Quelltextdatei. + Wird ein 'filename' ungleich niltext eingestellt, dann wird nach dem + Ausfhren eines 'LN'-Befehls (LineNumber) die Zeile mit dieser Nummer aus + der Quelldatei gelesen und parallel zur dekodierten EUMEL0-Instruktion + angezeigt. + + +PROC tracer channel (INT CONST) : +INT PROC tracerchannel : + Einstell- und Informationsprozeduren fr den Kanal, an dem das Programm + ausgefhrt werden soll. Die Ablaufverfolgung bleibt an dem Kanal, an dem + die PROC/OP aufgerufen wurde. + + +#ub#3.4.2 Aufruf des Tracers#ue# + + Eine PROC/OP, in der ein Breakpoint gesetzt wurde, kann zum Beispiel im + Monitor aufgerufen werden. Ab der Adresse, an der der Breakpoint gesetzt + wurde, kann die Abarbeitung des Codes verfolgt werden. Das Setzen der + Breakpoints geschieht mit 'set breakpoint'. + + +PROC trace : + Diese Prozedur erfragt vom Benutzer die PROC/OP, bei der der die + Ablaufverfogung beginnen soll. Anschlieáend muá der Aufruf der PROC/OP + eingegeben werden. Der Benutzer wird auáerdem nach dem Namen der + compilierten Quelldatei, dem Namen der Protokollfile und dem + Abarbeitungskanal gefragt. Nachdem alle Angaben gemacht worden sind, wird + der PROC/OP-Aufruf mit 'do' ausgefhrt. + + +PROC set breakpoint : + Die Modultabelle wird ggf. erweitert, der Benutzer wird nach dem Namen + einer PROC/OP gefragt, deren Codeabarbeitung verfolgt werden soll. Der Code + dieser PROC/OP muá im Codesegment 3 stehen (sonst erfolgt ein 'errorstop'). + Der Protokoll- und Sourcefilename werden auf niltext gesetzt. + + +PROC set breakpoint (INT CONST breakpointnr, address) : + Setzt an der bergebenen Codeadresse im Segment 3 einen Breakpoint der + beiden Breakpoints (1 oder 2 als 'breakpointnr'). Der Benuzter ist selbst + dafr verantwortlich daá + - dies nicht die Einsprungsadresse eines Moduls ist (HEAD-Instruktion), + - die bergebene Adresse das erste (Opcode-) Wort einer Instruktion ist, + - vor dem Aufruf des Moduls die Paketbasis korrekt gesetzt ist, falls + vor der ersten Instruktion mit Parametern kein 'PENTER' ausgefhrt wird. + + +PROC reset breakpoints : + Die Breakpoints werden zurckgesetzt und der (wegen des Breakpointhandler- + CALLs) gesicherte Code wieder an seinen Originalplatz zurckgeschrieben. + + +PROC reset breakpoint (INT CONST breakpointnr) : + Es wird nur gezielt der eine Breakpoint mit der Nummer 'breakpointnr' + zurckgesetzt. + + +PROC list breakpoints : + Der Status, die Adresse und der gesicherte Code (an dieser Adresse) werden + fr beide Breakpoints gelistet. diff --git a/devel/debugger/src/DEBUGGER.ELA b/devel/debugger/src/DEBUGGER.ELA new file mode 100644 index 0000000..fddde7d --- /dev/null +++ b/devel/debugger/src/DEBUGGER.ELA @@ -0,0 +1,3151 @@ +(*************************************************************************) +(** **) +(* EUMEL - Debugger: (C) Michael Staubermann, Oktober/November '86 *) +(* Ab EUMEL 1.7.5.4 *) +(* Stand: 01.12.86, 1.8.2: 26.07.88 *) +(* Noch keine BOUND-Variablen-Zugriffe implementiert *) +(** **) +(*************************************************************************) + + +PACKET address DEFINES ADD, (* 1.7.5 861006 *) + SUB, (* 1.8.0 861022 *) + MUL, (* M. Staubermann*) + INC, + DEC, + ulseq, + + split word , + make word , + + hex16, + hex8 , + integer , + + cdbint , + cdbtext , + + get word , + put word : + + +(*********************** Hex-Konvertierung ********************************) + +LET hex digits = "0123456789ABCDEF" ; + +PROC paket initialisierung : + (* Paketinitialisierung, wird nur einmal durchlaufen *) + INT CONST ulseq addr :: getword (0, 512 + + mod nr (BOOL PROC (INT CONST, INT CONST) ulseq)) ADD 2 ; + IF getword (3, ulseq addr) = integer ("B009") (* bei checkoff LSEQ *) + THEN putword (3, ulseq addr, integer ("D409")) (* ULSEQ *) + ELIF getword (3, ulseq addr ADD 1) = integer ("B009") (* bei checkon *) + THEN putword (3, ulseq addr ADD 1, integer ("D409")) + FI + +ENDPROC paket initialisierung ; + +INT PROC integer (TEXT CONST hex) : + INT VAR summe := 0, i ; + FOR i FROM 1 UPTO min (4, LENGTH hex) REP + rotate (summe, 4) ; + summe INCR digit + PER ; + summe . + +digit : + TEXT CONST char := hex 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 digits SUB ((wert DIV 16) +1)) + + (hex digits SUB ((wert AND 15) +1)) + +ENDPROC hex8 ; + +TEXT PROC hex16 (INT CONST wert) : + TEXT VAR result := "" ; + INT VAR i, w := wert ; + FOR i FROM 1 UPTO 4 REP + rotate (w, 4) ; + result CAT (hex digits SUB ((w AND 15)+1)) + PER ; + result + +ENDPROC hex16 ; + +(***************************** Adressarithmetik ***************************) + +PROC arith 15 : + + EXTERNAL 91 + +ENDPROC arith 15 ; + + +PROC arith 16 : + + EXTERNAL 92 + +ENDPROC arith 16 ; + + +OP INC (INT VAR a) : + arith 16 ; + a INCR 1 + +ENDOP INC ; + + +OP DEC (INT VAR a) : + arith 16 ; + a DECR 1 + +ENDOP DEC ; + + +INT OP ADD (INT CONST left, right) : + arith 16 ; + left + right + +ENDOP ADD ; + +INT OP SUB (INT CONST left, right) : + arith16 ; + left - right + +ENDOP SUB ; + +INT OP MUL (INT CONST left, right) : + arith 16 ; + left * right (* Multiplikation MOD 65536 im Gegensatz zu IMULT *) + +ENDOP MUL ; + +BOOL PROC ulseq (INT CONST left, right) : + left <= right (* Muá leider(!!) auf ULSEQ Code gepatcht werden *) +ENDPROC ulseq ; + +(*************************** Wortoperationen ******************************) + +PROC split word (INT VAR word and high byte, low byte) : + + EXTERNAL 15 + +ENDPROC split word ; + + +PROC make word (INT VAR highbyte and resultword, INT CONST low byte) : + + EXTERNAL 16 + +ENDPROC make word ; + + +(************************** DS4-Access ***********************************) + +INT PROC cdbint (INT CONST adr) : + + EXTERNAL 116 + +ENDPROC cdbint ; + + +TEXT PROC cdbtext (INT CONST adr) : + + EXTERNAL 117 + +ENDPROC cdbtext ; + + +PROC putword (INT CONST segment, adr, value) : + + EXTERNAL 119 + +ENDPROC put word ; + + +INT PROC getword (INT CONST segment, adr) : + + EXTERNAL 120 + +ENDPROC getword ; + + +INT PROC mod nr (BOOL PROC (INT CONST, INT CONST) proc) : + + EXTERNAL 35 + +ENDPROC mod nr ; + + +paket initialisierung + +ENDPACKET address ; + +(**************************************************************************) + +PACKET table routines DEFINES (* Fr eumel decoder 861017 *) + (* 1.8.0 by M.Staubermann *) + code segment , + code address , + packet name , + module name and specifications , + get module number , + storage , + hash , + init module table, + add modules , + dump tables : + + +LET end of hash table = 1023 , + begin of permanent table = 22784 , + begin of pt minus ptt limit = 12784 , + end of permanent table = 32767 , + + permanent param const = 10000 , + permanent param var = 20000 , + permanent proc op = 30000 , + permanent type = 30000 , + permanent row = 10 , + permanent struct = 11 , + permanent param proc = 12 , + permanent struct end = 0 , + + ptt limit = 10000 , + + void = 0 , + + const = 1 , + var = 2 , + + sysgenoff module number = 1280 , + start of module number link table = 512 , + highest module number 1 = 2048 , + max packets = 128 , + max types = 64 ; + + +LET MODULETABLE = ROW highest module number 1 + STRUCT (TEXT name, specifications, INT packet link) , + PACKETTABLE = ROW max packets STRUCT (TEXT name, INT permanent address), + TYPETABLE = STRUCT (THESAURUS names, ROW max types INT storage), + TABLETYPE = BOUND STRUCT (MODULETABLE module, PACKETTABLE packet, + TYPETABLE types, INT number of packets, + end of permanent table) ; + +TABLETYPE VAR table ; + +TEXT VAR type and mode, result ; +BOOL VAR end of params ; +INT VAR mode, paramlink, index ; + +(************************* Module- und Packettablezugriff **************) + +PROC init module table (TEXT CONST table name) : + forget (table name, quiet) ; + table := new (table name) ; + table.number of packets := 0 ; + table.end of permanent table := begin of permanent table ; + + table.types.names := empty thesaurus ; + insert (table.types.names, "INT", index) ; + table.types.storage (index) := 1 ; + insert (table.types.names, "REAL", index) ; + table.types.storage (index) := 4 ; + insert (table.types.names, "BOOL", index) ; + table.types.storage (index) := 1 ; + insert (table.types.names, "TEXT", index) ; + table.types.storage (index) := 8 ; + insert (table.types.names, "DATASPACE", index) ; + table.types.storage (index) := 1 ; + + scan permanent table (table.end of permanent table) ; + scan hash table (begin of permanent table) ; + +ENDPROC init module table ; + + +PROC add modules : + INT CONST old end of permanent table := table.end of permanent table ; + IF cdbint (table.end of permanent table) <> -3 + THEN scan permanent table (table.end of permanent table) ; + scan hash table (old end of permanent table) + FI + +ENDPROC add modules ; + + +PROC scan hash table (INT CONST minimum permanent address) : + INT VAR hash table pointer ; + FOR hash table pointer FROM 0 UPTO end of hash table REP + IF cdbint (hash table pointer) <> 0 + THEN cout (hash table pointer) ; + list all name table objects with this hash code (hash table pointer, + minimum permanent address) + FI + PER + +ENDPROC scan hash table ; + + +PROC list all name table objects with this hash code (INT CONST link, + minimum permanent address) : + TEXT VAR object name ; + INT VAR name table pointer := first link word, module nr, + permanent pointer ; + WHILE NOT end of name table chain REPEAT + permanent pointer := cdb int (nametable pointer + 1) ; + WHILE permanent pointer >= minimum permanent address REP + object name := cdbtext (name table pointer + 2) ; + IF permanent type definition + THEN insert (table.types.names, object name, index) ; + table.types.storage (index) := cdb int (permanent pointer + 2) + ELSE get specifications (permanent pointer) ; + module nr := cdb int (param link + 1) + 1; + table.module (module nr).name := object name ; + table.module (module nr).specifications := result; + table.module (module nr).packet link := packetlink(permanentpointer) + FI ; + permanent pointer := cdb int (permanent pointer) + PER ; + name table pointer := cdb int (name table pointer) + END REPEAT . + +first link word : + cdb int (link) . + +end of name table chain : + name table pointer = 0 . + +permanent type definition : + (object name SUB 1) <= "Z" AND (object name SUB 1) >= "A" AND + cdbint (permanent pointer + 1) = permanent type + +END PROC list all name table objects with this hash code ; + + +INT PROC packet link (INT CONST permanent address) : + INT VAR packet pointer ; + FOR packet pointer FROM 1 UPTO table.number of packets REP + IF table.packet (packet pointer).permanent address > permanent address + THEN LEAVE packet link WITH packet pointer -1 + FI + PER ; + table.number of packets + +ENDPROC packet link ; + + +PROC scan permanent table (INT VAR permanent pointer) : + FOR permanent pointer FROM permanent pointer UPTO end of permanent table + WHILE cdbint (permanent pointer) <> -3 REP + IF cdbint (permanent pointer) = -2 + THEN cout (permanent pointer) ; + table.number of packets INCR 1 ; + table.packet (table.number of packets).name := + cdbtext (cdbint (permanent pointer +1) +2) ; + table.packet (table.number of packets).permanent address := + permanent pointer + FI + PER + +ENDPROC scan permanent table ; + + +PROC dump tables (TEXT CONST file name) : + INT VAR i ; + forget (filename, quiet) ; + FILE VAR f := sequentialfile (output, filename) ; + maxline length (f, 1000) ; + + putline (f, "PACKETTABLE:") ; + put (f, "End of Permanenttable:") ; + put (f, hex16 (table.end of permanent table)) ; + line (f) ; + putline (f, "Nr. Packetname") ; + FOR i FROM 1 UPTO table.number of packets REP + cout (i) ; + put (f, text (i, 3)) ; + put (f, hex16 (table.packet (i).permanent address)) ; + putline (f, table.packet (i).name) + PER ; + line (f, 2) ; + putline (f, "TYPETABLE:") ; + putline (f, " Size Name") ; + index := 0 ; + get (table.types.names, type and mode, index) ; + WHILE index > 0 REP + put (f, text (table.types.storage (index), 5)) ; + putline (f, type and mode) ; + get (table.types.names, type and mode, index) + PER ; + line (f, 2) ; + putline (f, "MODULETABLE:") ; + putline (f, "Modnr.PNr.Name and Parameters") ; + FOR i FROM 1 UPTO highest module number 1 REP + IF table.module (i).packet link <> -1 + THEN cout (i) ; + put (f, text (i-1, 5)) ; + put (f, text (table.module (i).packet link, 3)) ; + put (f, table.module (i).name) ; + putline (f, table.module (i).specifications) ; + FI + PER + +ENDPROC dump tables ; + + +INT PROC storage (TEXT CONST typename) : + index := link (table.types.names, typename) ; + IF index = 0 + THEN 0 + ELSE table.types.storage (index) + FI + +ENDPROC storage ; + + +TEXT PROC module name and specifications (INT CONST module number) : + IF LENGTH table.module (module number + 1).name > 0 + THEN table.module (module number + 1).name + " " + + table.module (module number + 1).specifications + ELSE "" + FI + +ENDPROC module name and specifications ; + + +TEXT PROC packet name (INT CONST module number) : + IF table.module (module number + 1).packet link > 0 + THEN table.packet (table.module (module number + 1).packet link).name + ELSE FOR index FROM module number DOWNTO 1 REP + IF table.module (index).packet link > 0 + THEN LEAVE packet name WITH table.packet (table.module + (index).packet link).name + FI + PER ; + "" + FI + +ENDPROC packet name ; + + +(************************ Modulnummern ***********************************) + +INT PROC code segment (INT CONST module number) : + IF module number < sysgen off module number + THEN 2 + ELSE 3 + FI + +ENDPROC code segment ; + + +INT PROC code address (INT CONST module number) : + get word (0, start of module number link table + module number) +ENDPROC code address ; + + +PROC get module number (INT VAR module number) : + TEXT VAR object ; + INT VAR anz objects, name table pointer, permanent pointer ; + put ("Name oder Modulnummer der PROC/OP:") ; + getline (object) ; + changeall (object, " ", "") ; + IF object = "" + THEN LEAVE get module number + FI ; + disablestop ; + module number := int (object) ; + IF NOT iserror AND last conversion ok AND module number >= -1 AND + module number < 2048 + THEN LEAVE get module number + FI ; + clear error ; + enablestop ; + anz objects := 0 ; + FILE VAR f := notefile ; + maxlinelength (f, 1000) ; + note ("Modulnummer des gewnschten Objekts merken und ESC q tippen.") ; + noteline ; + noteline ; + module number := -1 ; + scan permanent table chain with object name ; + IF anz objects > 1 + THEN note edit ; + put ("Modulnummer der PROC/OP:") ; + get (module number) + ELSE type (""27"q") ; + note edit + FI . + +scan permanent table chain with object name : + name table pointer := first link word ; + WHILE NOT end of name table chain REP + IF cdb text (name table pointer + 2) = object + THEN permanent pointer := cdb int (nametable pointer + 1) ; + IF NOT permanent type definition + THEN run through permanent chain + FI ; + FI ; + name table pointer := cdb int (name table pointer) + PER . + +run through permanent chain : + WHILE permanent pointer <> 0 REP + anz objects INCR 1 ; + cout (anz objects) ; + get specifications (permanent pointer) ; + IF anz objects = 1 + THEN module number := module nr + FI ; + note (text (module nr, 4)) ; + note (" ") ; + note (object) ; + note (" ") ; + note (result) ; + noteline ; + permanent pointer := cdbint (permanent pointer) + PER . + +module nr : + cdb int (param link + 1) . + +first link word : + cdb int (hash (object)) . + +end of name table chain : + name table pointer = 0 . + +permanent type definition : + (object SUB 1) <= "Z" AND (object SUB 1) >= "A" AND + cdbint (permanent pointer + 1) = permanent type + +ENDPROC get module number ; + + +(************************* Permanenttabellenzugriffe **********************) + +INT PROC hash (TEXT CONST obj name) : + INT VAR i, hash code ; + hash code := 0 ; + FOR i FROM 1 UPTO LENGTH obj name REP + addmult cyclic + PER ; + hash code . + +addmult cyclic : + hash code INCR hash code ; + IF hash code > end of hash table THEN wrap around FI ; + hash code := (hash code + code (obj name SUB i)) AND end of hash table . + +wrap around : + hash code DECR end of hash table + +ENDPROC hash ; + + +PROC next pt param : + mode := cdb int (param link) MOD ptt limit ; + param link INCR 1 ; + IF mode = permanent row + THEN skip over permanent row + ELIF mode = permanent struct + THEN skip over permanent struct + FI ; + set end marker if end of list . + +skip over permanent row : + param link INCR 1 ; (* Skip row size *) + next pt param . + +skip over permanent struct : + mode := cdbint (param link) ; + WHILE mode <> permanent struct end REP + next pt param ; + mode := cdbint (param link) + PER ; + param link INCR 1 (* skip permanent struct end *) + +ENDPROC next pt param ; + + +PROC set end marker if end of list : + mode := cdb int (param link) ; + end of params := mode >= permanent proc op OR mode <= 0 + +ENDPROC set end marker if end of list ; + + +PROC get type and mode (INT VAR type) : + mode := cdb int (param link) ; + IF mode = permanent param proc + THEN type of param proc + ELSE type of object + FI . + +type of param proc : + param link INCR 1 ; + get type and mode (type) ; + mode := permanent param proc . + +type of object : + IF mode < 0 + THEN type := 2769 + (32767 + mode) ; + mode := 0 + ELSE type := mode MOD ptt limit ; + mode DECR type ; + translate type if necessary ; + translate mode if necessary + FI . + +translate type if necessary : + IF permanent row or struct THEN translate type FI . + +translate type : + type := param link - begin of pt minus ptt limit . + +translate mode if necessary : + IF mode = permanent param const + THEN mode := const + ELIF mode = permanent param var + THEN mode := var + FI . + +permanent row or struct : + type = permanent row OR type = permanent struct + +ENDPROC get type and mode ; + + +PROC get specifications (INT CONST permanent pointer) : + result := "" ; + to first param ; + IF NOT end of params THEN put param list FI ; + get result . + +to first param : + param link := permanent pointer + 1 ; + set end marker if end of list . + +get result : + INT VAR type; + get type and mode (type) ; + IF type <> void + THEN type and mode := " --> " ; + name of type (type) ; + result CAT type and mode + FI + +ENDPROC get specifications ; + + +PROC put param list : + result CAT "(" ; + REP + INT VAR type; + get type and mode (type) ; + put type and mode ; + maybe param proc ; + next pt param ; + IF end of params + THEN result CAT ")" ; + LEAVE put param list + FI ; + result CAT ", " ; + PER . + +put type and mode : + INT CONST mode1 :: mode ; + type and mode := "" ; + name of type (type) ; + type and mode CAT name of mode ; + result CAT type and mode . + +name of mode : + IF mode1 = const THEN " CONST" + ELIF mode1 = var THEN " VAR" + ELIF type = void THEN "PROC" + ELSE " PROC" + FI . + +maybe param proc : + IF mode = permanent param proc THEN put virtual params FI . + +put virtual params : + skip over result type if complex type ; + IF NOT end of virtual params + THEN result CAT " " ; + put param list + FI . + +skip over result type if complex type : + next pt param . + +end of virtual params : + end of params + +ENDPROC put param list ; + + +PROC name of type (INT CONST type) : + LET int = 1 , + real = 2 , + string = 3 , + bool = 5 , + bool result = 6 , + dataspace = 7 ; + + SELECT type OF + CASE void : + CASE int : type and mode CAT "INT" + CASE real : type and mode CAT "REAL" + CASE string : type and mode CAT "TEXT" + CASE bool, + bool result : type and mode CAT "BOOL" + CASE dataspace : type and mode CAT "DATASPACE" + OTHERWISE complex type + ENDSELECT . + +complex type : + IF type > ptt limit THEN perhaps permanent struct or row + ELSE get complex type + FI . + +perhaps permanent struct or row : + index := type + begin of pt minus ptt limit ; + mode := cdb int (index) MOD ptt limit ; + IF mode = permanent row THEN get permanent row + ELIF mode = permanent struct THEN get permanent struct + ELSE type and mode CAT "-" + FI . + +get complex type : + index := type + begin of permanent table ; + IF is complex type + THEN get name + ELSE type and mode CAT "" + FI . + +is complex type : + permanent type definition mode = permanent type . + +get name : + type and mode CAT cdb text (link to type name + 2) . + +link to type name : + cdb int (index + 3) . + +permanent type definition mode : + cdb int (index + 1) . + +get permanent row : + INT VAR t; + type and mode CAT "ROW " ; + type and mode CAT text (cdb int (index + 1)) ; + type and mode CAT " " ; + param link := index + 2 ; + get type and mode (t) ; + name of type (t) . + +get permanent struct : + type and mode CAT "STRUCT (" ; + param link := index + 1 ; + WHILE within permanent struct REP + get type and mode (t) ; + name of type (t) ; + next pt param ; + IF within permanent struct + THEN type and mode CAT ", " + FI + PER ; + type and mode CAT ")" . + +within permanent struct : + cdbint (param link) <> permanent struct end . + +ENDPROC name of type ; + + +ENDPACKET table routines ; + + +(*************************************************************************) + +PACKET eumel decoder DEFINES (* M. Staubermann, M„rz/April 86 *) + (* 1.8.0 861201 *) + (* 1.8.2 880726 *) + lbase , + pbase , + set parameters , + get parameters , + default no runtime , + bool result , + line number , + list file name , + last actual parameter , + with code words , + with object address , + + next word , + next module header , + data representation , + object representation , + + decode module , + decode : + + +LET packet data segment = 0 , + local data segment = 1 , + standard dataspace = 0 , (* ds = 4 *) + + first elan address = 13 584 , (* codeaddress (273) *) + begin of stringtable = 1 024 , + begin of nametable = 4 096 , + end of nametable = 22 783 ; + +LET try type = 0 , {?} + int addr = 10 , {I} + real addr = 19 , {R} + text addr = 20 , {S} + dataspace addr = 5 , {D} + task addr = 21 , {T} + ref addr = 1 , {@} + mod addr = 2 , {A} + bool addr = 3 , {B} + int value = 23 , {V} + hexbyte value = 9 , {H} + module nr value = 14 ; {M} + +LET OPN = STRUCT (TEXT mnemonic, params, BOOL bool result) , + PRIMOP = ROW 31 OPN , + SPECIALOP = ROW 6 OPN , + ESCOP = ROW 130 OPN , + + rtnt opcode = 32513 , + rtnf opcode = 32514 ; + +LET hex 3fff = 16 383 , + hex 03ff = 1 023 , + hex 0400 = 1 024 , + hex 7c = 124 , + hex 7f = 127 , + hex f0 = 240 , + hex fd = 253 , + hex ff = 255 ; + +INT CONST hex 83ff :: -31745 , + hex ff00 :: -256 , + hex fff8 :: -8 , + minus one :: -1 ; + +FILE VAR list file ; +TEXT VAR file name := "" , + text val := "" ; +INT VAR file number := 0 , + data base , + ln := minus one , + lbas := minus one , + cmod := minus one ; + +BOOL VAR was bool result , + echo , + with statement line := TRUE , + with object and address := TRUE ; + + +INT PROC line number : + ln +ENDPROC line number ; + + +TEXT PROC last actual parameter : + text val +ENDPROC last actual parameter ; + + +PROC pbase (INT CONST i) : + data base := i ; + makeword (data base, 0) +ENDPROC pbase ; + + +INT PROC pbase : + INT VAR lowbyte, highbyte := data base ; + split word (highbyte, lowbyte) ; + highbyte +ENDPROC pbase ; + + +PROC lbase (INT CONST i) : + lbas := i +ENDPROC lbase ; + + +BOOL PROC bool result : + was bool result +ENDPROC bool result ; + + +BOOL PROC with object address : + with object and address +ENDPROC with object address ; + + +PROC with object address (BOOL CONST b) : + with object and address := b +ENDPROC with object address ; + + +PROC with codewords (BOOL CONST b) : + with statement line := b +ENDPROC with codewords ; + + +BOOL PROC with codewords : + with statement line +ENDPROC with codewords ; + + +PROC bool result (BOOL CONST b) : + was bool result := b +ENDPROC bool result ; + + +PROC list file name (TEXT CONST name) : + file name := name +ENDPROC list file name ; + + +PROC set parameters (INT CONST lbase, pbas, line number, codmod) : + lbas := lbase ; + pbase (pbas) ; + ln := line number ; + cmod := codmod +ENDPROC set parameters ; + + +PROC get parameters (INT VAR lbase, pbas, line number, codmod) : + lbase := lbas ; + pbas := pbase ; + line number := ln ; + codmod := cmod +ENDPROC get parameters ; + + +PROC default no runtime : + lbas := minus one ; + ln := minus one ; + database := minus one ; + cmod := minus one +ENDPROC default no runtime ; + + +PRIMOP CONST primop := PRIMOP :( + OPN :("LN ", "V", FALSE), (* 1 *) + OPN :("LN1 ", "V", FALSE), + OPN :("MOV ", "II", FALSE), + OPN :("INC1 ", "I", FALSE), + OPN :("DEC1 ", "I", FALSE), + OPN :("INC ", "II", FALSE), + OPN :("DEC ", "II", FALSE), + OPN :("ADD ", "III", FALSE), + OPN :("SUB ", "III", FALSE), + OPN :("CLEAR", "I", FALSE), (* 10 *) + OPN :("TEST ", "I", TRUE), + OPN :("EQU ", "II", TRUE), + OPN :("LSEQ ", "II", TRUE), + OPN :("FMOV ", "RR", FALSE), + OPN :("FADD ", "RRR", FALSE), + OPN :("FSUB ", "RRR", FALSE), + OPN :("FMUL ", "RRR", FALSE), + OPN :("FDIV ", "RRR", FALSE), + OPN :("FLSEQ", "RR", TRUE), + OPN :("TMOV ", "SS", FALSE), + OPN :("TEQU ", "SS", TRUE), + OPN :("ULSEQ", "II", TRUE), + OPN :("DSACC", "D?", FALSE), + OPN :("REF ", "?@", FALSE), + OPN :("SUBS ", "VVI?@", FALSE), (* 25 *) + OPN :("SEL ", "?V@", FALSE), (* 26 *) + OPN :("PPV ", "?", FALSE), + OPN :("PP ", "?", FALSE), + OPN :("B ", "V", FALSE), + OPN :("B1 ", "V", FALSE), + OPN :("CALL ", "M", FALSE)) ; + +SPECIALOP CONST special op := SPECIALOP :( + OPN :("EQUIM ", "HI", TRUE), + OPN :("MOVi ", "HI", FALSE), + OPN :("MOVx ", "HII", FALSE), + OPN :("PUTW ", "HII", FALSE), + OPN :("GETW ", "HII", FALSE), + OPN :("PENTER ", "H", FALSE)) ; (* 7F = ESC, FF = LONGA *) + +ESCOP CONST esc op := ESCOP :( + OPN :("RTN ", "", FALSE), (* 0 *) + OPN :("RTNT ", "", FALSE), + OPN :("RTNF ", "", FALSE), + OPN :("???????", "", FALSE), (* was repair text 1.7.1 *) + OPN :("STOP ", "", FALSE), (* TERM *) + OPN :("GOSUB ", "V", FALSE), (* 1 ist Branch Address *) + OPN :("KE ", "", FALSE), + OPN :("GORET ", "", FALSE), + OPN :("BCRD ", "II", FALSE), (* begin char read (pointer, length) *) + OPN :("CRD ", "II", FALSE), (* char read (char, pointer) *) + OPN :("ECWR ", "III", FALSE), (* end char write (pointer, length, next entry) *) + OPN :("CWR ", "III", FALSE), (* char write (hash code, pointer, char) *) + OPN :("CTT ", "?S", FALSE), (* REF d2:=REF compiler table text ) *) + OPN :("GETC ", "SII", TRUE), (* INT := code (TEXT SUB INT), TRUE wenn INT <= length (TEXT) *) + OPN :("FNONBL ", "ISI", TRUE), (* find non blank (char, line, pointer) *) + OPN :("DREM256", "II", FALSE), (* := MOD 256, := DIV 256 *) + OPN :("AMUL256", "II", FALSE), (* := * 256 + *) + OPN :("???????", "", FALSE), + OPN :("ISDIG ", "I", TRUE), + OPN :("ISLD ", "I", TRUE), + OPN :("ISLCAS ", "I", TRUE), + OPN :("ISUCAS ", "I", TRUE), + OPN :("GADDR ", "III", FALSE), (* IF >= 0 (Global) THEN := - (=pbase) ELIF bit (, 14) (Local Ref) THEN := ( AND $3FFF)*2 + 1 ELSE (Local) := ( AND $3FFF)*2 FI *) + OPN :("GCADDR ", "III", TRUE), + OPN :("ISSHA ", "I", TRUE), + OPN :("SYSG ", "", FALSE), (* 25 *) + OPN :("GETTAB ", "", FALSE), + OPN :("PUTTAB ", "", FALSE), + OPN :("ERTAB ", "", FALSE), + OPN :("EXEC ", "M", FALSE), + OPN :("PPROC ", "M", FALSE), + OPN :("PCALL ", "A", FALSE), (* : icount Segment/Address *) + OPN :("BRCOMP ", "IV", FALSE), + OPN :("MOVxx ", "V??", FALSE), + OPN :("ALIAS ", "VDD", FALSE), + OPN :("MOVii ", "VI", FALSE), + OPN :("FEQU ", "RR", TRUE), + OPN :("TLSEQ ", "SS", TRUE), + OPN :("FNEG ", "RR", FALSE), + OPN :("NEG ", "II", FALSE), + OPN :("IMULT ", "III", FALSE), + OPN :("MUL ", "III", FALSE), + OPN :("DIV ", "III", FALSE), + OPN :("MOD ", "III", FALSE), + OPN :("ITSUB ", "SII", FALSE), + OPN :("ITRPL ", "SII", FALSE), + OPN :("DECOD ", "SI", FALSE), + OPN :("ENCOD ", "IS", FALSE), + OPN :("SUBT1 ", "SIS", FALSE), + OPN :("SUBTFT ", "SIIS", FALSE), + OPN :("SUBTF ", "SIS", FALSE), + OPN :("REPLAC ", "SIS", FALSE), + OPN :("CAT ", "SS", FALSE), + OPN :("TLEN ", "SI", FALSE), + OPN :("POS ", "SSI", FALSE), + OPN :("POSF ", "SSII", FALSE), + OPN :("POSFT ", "SSIII", FALSE), + OPN :("STRANL ", "IIISIII", FALSE), + OPN :("POSIF ", "SSSII", FALSE), + OPN :("???????", "", FALSE), + OPN :("OUT ", "S", FALSE), (* 60 *) + OPN :("COUT ", "I", FALSE), + OPN :("OUTF ", "SI", FALSE), + OPN :("OUTFT ", "SII", FALSE), + OPN :("INCHAR ", "S", FALSE), + OPN :("INCETY ", "S", FALSE), + OPN :("PAUSE ", "I", FALSE), + OPN :("GCPOS ", "II", FALSE), + OPN :("CATINP ", "SS", FALSE), + OPN :("NILDS ", "D", FALSE), + OPN :("DSCOPY ", "DD", FALSE), + OPN :("DSFORG ", "D", FALSE), + OPN :("DSWTYP ", "DI", FALSE), + OPN :("DSRTYP ", "DI", FALSE), + OPN :("DSHEAP ", "DI", FALSE), + OPN :("ESTOP ", "", FALSE), + OPN :("DSTOP ", "", FALSE), + OPN :("SETERR ", "I", FALSE), + OPN :("ISERR ", "", TRUE), + OPN :("CLRERR ", "", FALSE), + OPN :("RPCB ", "II", FALSE), + OPN :("INFOPW ", "SSI", FALSE), (* War vorher Writepcb *) + OPN :("TWCPU ", "TR", FALSE), + OPN :("ROTATE ", "II", FALSE), + OPN :("CONTRL ", "IIII", FALSE), + OPN :("BLKOUT ", "DIIII", FALSE), + OPN :("BLKIN ", "DIIII", FALSE), + OPN :("NXTDSP ", "DII", FALSE), + OPN :("DSPAGS ", "ITI", FALSE), + OPN :("STORAGE", "II", FALSE), + OPN :("SYSOP ", "I", FALSE), (* 90 *) + OPN :("ARITHS ", "", FALSE), + OPN :("ARITHU ", "", FALSE), + OPN :("HPSIZE ", "I", FALSE), + OPN :("GARB ", "", FALSE), + OPN :("TPBEGIN", "TTIA", FALSE), (* 1.8.0: privileged begin *) + OPN :("FSLD ", "IRI", FALSE), + OPN :("GEXP ", "RI", FALSE), + OPN :("SEXP ", "IR", FALSE), + OPN :("FLOOR ", "RR", FALSE), + OPN :("RTSUB ", "SIR", FALSE), + OPN :("RTRPL ", "SIR", FALSE), + OPN :("CLOCK ", "IR", FALSE), + OPN :("SETNOW ", "R", FALSE), + OPN :("TRPCB ", "TII", FALSE), + OPN :("TWPCB ", "TII", FALSE), (* 105 *) + OPN :("TCPU ", "TR", FALSE), + OPN :("TSTAT ", "TI", FALSE), + OPN :("ACT ", "T", FALSE), + OPN :("DEACT ", "T", FALSE), + OPN :("THALT ", "T", FALSE), + OPN :("TBEGIN ", "TA", FALSE), (* seg/addr icount *) + OPN :("TEND ", "T", FALSE), + OPN :("SEND ", "TIDI", FALSE), + OPN :("WAIT ", "TID", FALSE), + OPN :("SWCALL ", "TIDI", FALSE), + OPN :("CDBINT ", "II", FALSE), (* 116 *) + OPN :("CDBTXT ", "IS", FALSE), (* 117 *) + OPN :("PNACT ", "I", FALSE), + OPN :("PW ", "III", FALSE), + OPN :("GW ", "III", FALSE), + OPN :("XOR ", "III", FALSE), + OPN :("PPCALL ", "TIDI", FALSE), (* pingpong call *) + OPN :("EXTASK ", "T", TRUE), + OPN :("AND ", "III", FALSE), + OPN :("OR ", "III", FALSE), + OPN :("SESSION", "I", FALSE), + OPN :("SENDFT ", "TTIDI", FALSE), + OPN :("DEFCOL ", "T", FALSE), + OPN :("ID ", "II", FALSE)) ; (* 129 *) + + +PROC decode : + INT VAR mod nr ; + get module number (mod nr) ; + IF mod nr >= minus one + THEN decode (mod nr) + FI +ENDPROC decode ; + + +PROC decode module : + INT VAR mod nr ; + get module number (mod nr) ; + IF mod nr >= minus one + THEN decode module (mod nr) + FI +ENDPROC decode module ; + + +PROC decode module (INT CONST mod nr) : + INT VAR address :: code address (mod nr) ; + default no runtime ; + decode (code segment (mod nr), address, minus one, TRUE) +ENDPROC decode module ; + + +PROC decode (INT CONST mod nr) : + INT VAR address :: code address (mod nr) ; + default no runtime ; + decode (code segment (mod nr), address, minus one, FALSE) +ENDPROC decode ; + + +PROC decode (INT CONST seg, from) : + INT VAR address := from ; + default no runtime ; + decode (seg, address, minus one, FALSE) +ENDPROC decode ; + + +PROC decode (INT CONST seg, INT VAR addr, INT CONST to addr, + BOOL CONST only one module) : + + TEXT VAR taste, opcode, codewords, hex addr ; + BOOL VAR addr out := TRUE , + output permitted := TRUE ; + INT VAR size, used, mod nr, header address, start address := addr ; + + add modules ; + storage (size, used) ; + echo := TRUE ; + file number := 0 ; + cmod := minus one ; + init list file ; + next module header (seg, addr, header address, mod nr) ; + was bool result := FALSE ; + + WHILE ulseq (addr, to addr) REP + protocoll ; + taste := incharety ; + decode one statement ; + analyze key ; + IF (addr AND 31) = 0 + THEN storage (size, used) ; + FI ; + UNTIL taste = ""27"" OR used > size PER ; + + IF used > size + THEN list line ("Abbruch wegen Speicherengpass!") + FI . + +protocoll : + IF output permitted AND NOT echo (* Falls Decoder im Hintergrund laufen soll *) + THEN IF addr out + THEN out (" ") ; + out (hex16 (addr)) ; + out (" "8""8""8""8""8""8"") ; + ELSE cout (ln) + FI + FI . + +analyze key : + SELECT code (taste) OF +{l} CASE 108 : addr out := FALSE (* Zeilennummern ausgeben *) +{d} CASE 100 : get command ("Gib Kommando:") ; do command +{f} CASE 102 : show filename and fileline +{a} CASE 97 : addr out := TRUE (* Hexaddressen ausgeben *) +{e} CASE 101 : echo := NOT echo (* Bildschirmausgabe zus. *) +{s} CASE 115 : storage (size,used) ; out(""13""5"System-Storage: " + text (used) + " ") +{m} CASE 109 : out (""13""5"Modulnr: " + text (mod nr-1) + " ") +{Q,W}CASE 87,81:output permitted := TRUE (* L„uft nur im Vordergrund *) +{S} CASE 83 : output permitted := FALSE (* L„uft auch im Hintergrund *) +{ESC}CASE 27 : IF incharety <> "" + THEN taste := "" + ELSE list line ("Abbruch mit ESC") + FI + (* Wegen Steuertasten, wie ESC P *) + ENDSELECT . + +show filename and fileline : + out (""13""5"Filename: " + filename + "." + text (filenumber) + + " Fileline: " + text (lines (list file)) + " ") . + +decode one statement : + check if module head ; + hex addr := hex16 (addr) ; + codewords := "" ; + opcode := "" ; + decode (seg, addr, codewords, opcode, INT PROC (INT CONST, INT VAR, TEXT VAR) next word) ; + hex addr CAT " " ; + hex addr CAT opcode ; + IF with statement line + THEN hex addr CAT " " ; + WHILE LENGTH hex addr < 80 REP + hex addr CAT " " + PER ; + hex addr CAT codewords ; + FI ; + list line (hex addr) . + +check if module head : + IF addr = header address + THEN IF only one module AND addr <> start address + THEN LEAVE decode + FI ; + list line (" ") ; + list line ("Module " + process module nr (mod nr)) ; + list line (" ") ; + IF output permitted AND NOT echo + THEN put ("Module:") ; + cout (mod nr) ; + 8 TIMESOUT ""8"" + FI ; + calculate c8k ; + codewords := "" ; + hex addr := hex16 (addr) ; + hex addr CAT " HEAD " ; + hex addr CAT text (next word (seg, addr, codewords)) ; + IF with statement line + THEN hex addr CAT " " ; + WHILE LENGTH hex addr < 80 REP + hex addr CAT " " + PER ; + hex addr CAT code words ; + FI ; + list line (hex addr) ; + next module header (seg, addr, header address, mod nr) ; + FI . + +calculate c8k : + INT VAR dummy ; + cmod := addr ; + splitword (cmod, dummy) ; + cmod INCR 16 ; + cmod := cmod AND 255 . + +ENDPROC decode ; + + +PROC init list file : + forget (filename + "." + text (filenumber), quiet) ; + list file := sequentialfile (output, filename + "." + text (filenumber)) ; + maxlinelength (list file, 2000) ; + list line ("Addr 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 outsubtext (zeile, 1, 79) ; line FI +ENDPROC list line ; + + +PROC decode (INT CONST segment, INT VAR address, TEXT VAR words, instruction, + INT PROC (INT CONST, INT VAR, TEXT VAR) next word) : + + INT VAR opcode, word, lowbyte, highbyte, + opcode address := address ; + BOOL VAR shorta opcode ; + + ln := minus one ; (* Wenn kein LN Befehl vorkam -1 *) + + word := next word (segment, address, words) ; + highbyte := word ; + split word (highbyte, lowbyte) ; + opcode := highbyte AND hex 7c ; + shorta opcode := TRUE ; + + IF opcode = hex 7c AND highbyte <> hex ff + THEN esc or special instruction (* Kann kein LONGA sein *) + ELSE IF highbyte = hex ff + THEN longa instruction + ELSE word := word AND hex 83ff + FI ; + primaer instruction + FI . + +esc or special instruction : + IF highbyte = hex 7f + THEN esc instruction + ELSE special instruction + FI . + +longa instruction : + IF lowbyte = hex ff + THEN instruction CAT "-" ; + LEAVE decode + ELIF lowbyte = hex fd + THEN instruction CAT "Block unlesbar" ; + LEAVE decode + ELSE instruction CAT "LONGA " ; + shorta opcode := FALSE ; + opcode := lowbyte ; + word := next word (segment, address, words) ; + highbyte := word ; + splitword (highbyte, lowbyte) + FI . + +special instruction : + opcode := (highbyte AND 3) * 2 + 1 ; + IF highbyte > hex 7f + THEN opcode INCR 1 + FI ; + word := word AND hex ff ; + instruction CAT special op (opcode).mnemonic ; + instruction CAT " " ; (* ESC Ausgleich *) + instruction CAT params0 (special op (opcode).params, word, segment, address, + words, INT PROC (INT CONST, INT VAR, TEXT VAR) next word) ; + was bool result := special op (opcode).bool result ; + IF opcode = 6 (* PENTER *) + THEN database := lowbyte ; + makeword (database, 0) ; + FI . + +esc instruction : + opcode := lowbyte + 1 ; + IF opcode < 1 OR opcode > 131 + THEN instruction CAT "???????" + ELSE instruction CAT "ESC " ; + instruction CAT esc op (opcode).mnemonic ; + instruction CAT " " ; + instruction CAT params (esc op (opcode).params, segment, address, + words, INT PROC (INT CONST, INT VAR, TEXT VAR) next word) ; + was bool result := esc op (opcode).bool result + FI . + +primaer instruction : + rotate (opcode, -2) ; + SELECT opcode OF + CASE 0, 1 : process ln + CASE 28, 29 : process br + CASE 30 : process call + OTHERWISE + opcode INCR 1 ; + instruction CAT prim op (opcode).mnemonic ; + IF shorta opcode + THEN instruction CAT " " + ELSE instruction CAT " " + FI ; + instruction CAT params0 (prim op (opcode).params, word, segment, address, words, + INT PROC (INT CONST, INT VAR, TEXT VAR) next word) ; + IF opcode = 25 (* SUBS *) + THEN instruction CAT "(ESiz,Lim-1,Idx,Base,Ref) " + ELIF opcode = 26 (* SEL *) + THEN instruction CAT "(Base,Offs,Ref) " + FI ; + was bool result := prim op (opcode).bool result ; + ENDSELECT . + +process call : + opcode INCR 1 ; + word := word AND hex 03ff ; + IF highbyte > hex 7f + THEN word INCR hex 0400 + FI ; + instruction CAT prim op (opcode).mnemonic ; + IF shorta opcode + THEN instruction CAT " " + ELSE instruction CAT " " + FI ; + was bool result := FALSE ; (* Wird von params0 ggf berschrieben *) + instruction CAT params0 (prim op (opcode).params, word, segment, address, words, + INT PROC (INT CONST, INT VAR, TEXT VAR) next word) . + +process ln : + IF shorta opcode + THEN word := short address (lowbyte, highbyte, opcode = 1) + FI ; + IF was bool result + THEN instruction CAT "BT " ; + IF shorta opcode + THEN instruction CAT " " + FI ; + instruction CAT hex16 (branch address) + ELSE IF segment = 2 + THEN instruction CAT "HEAD " + ELSE ln := word ; + instruction CAT "LN " + FI ; + IF shorta opcode + THEN instruction CAT " " + FI ; + instruction CAT text (word) + FI ; + was bool result := FALSE . + +process br : + word := short address (lowbyte, highbyte, opcode = 29) ; + IF was bool result + THEN instruction CAT "BF " ; + ELSE instruction CAT "B " ; + FI ; + IF shorta opcode + THEN instruction CAT " " + FI ; + instruction CAT hex16 (branch address) ; + was bool result := FALSE . + +branch address : + INT VAR high address byte := opcode address ; + split word (high address byte, lowbyte) ; + highbyte := word ; + split word (highbyte, lowbyte) ; + high address byte INCR highbyte ; + IF cmod <> minus one AND high address byte >= cmod + THEN high address byte DECR 16 (* cms = 16 *) + FI ; + make word (high address byte, lowbyte) ; + high address byte . + +ENDPROC decode ; + + +INT PROC short address (INT CONST lowbyte, highbyte, BOOL CONST bit12) : + (* Bit 7 des Highbytes in Bit 0 rotieren *) + INT VAR effective address := (highbyte * 2) AND 6 ; + IF highbyte > hex 7f + THEN effective address INCR 1 + FI ; + make word (effective address, lowbyte) ; (* high and result, low *) + IF bit12 + THEN effective address INCR 2048 + FI ; + effective address + +ENDPROC short address ; + + +INT PROC next word (INT CONST segment, INT VAR address, TEXT VAR words) : + INT CONST word :: get word (segment, address) ; + INC address ; + words CAT hex16 (word) ; + words CAT " " ; + word + +ENDPROC next word ; + + +PROC next module header (INT CONST segment, address, + INT VAR header address, module number) : + INT VAR first, last, mid ; + IF segment = 2 + THEN first := 0 ; + last := 1275 + ELSE first := 1282 ; (* 1280/1281 MAIN doagain & runagain modaddr *) + last := 2047 + FI ; + REP + mid := (first + last) DIV 2 ; + IF ulseq (address, getword (0, 512 + mid)) + THEN last := mid + ELSE first := mid + 1 + FI + UNTIL first = last PER ; + header address := getword (0, 512 + first) ; + module number := first + +ENDPROC next module header ; + + +TEXT PROC params (TEXT CONST types, INT CONST segment, INT VAR address, + TEXT VAR words, INT PROC (INT CONST, INT VAR, TEXT VAR) next word) : + + INT VAR i, param addr, type ; + TEXT VAR result ; + + IF types = "" + THEN LEAVE params WITH "" + FI ; + result := "" ; + FOR i FROM 1 UPTO LENGTH types REP + param addr := next word (segment, address, words) ; + type := code (types SUB i)-63 ; + result CAT data representation (param addr, segment, address, type) ; + IF i <> LENGTH types + THEN result CAT ", " + FI ; + PER ; + result + +ENDPROC params ; + + +TEXT PROC params0 (TEXT CONST types, INT CONST word, segment, INT VAR address, + TEXT VAR words, INT PROC (INT CONST, INT VAR, TEXT VAR) next word) : + + INT VAR i, param addr, type ; + TEXT VAR result ; + + IF types = "" + THEN LEAVE params0 WITH "" + FI ; + result := "" ; + param addr := word ; + FOR i FROM 1 UPTO LENGTH types REP + type := code (types SUB i)-63 ; + result CAT data representation (param addr, segment, address, type) ; + IF i <> LENGTH types + THEN result CAT ", " ; + param addr := next word (segment, address, words) + FI + PER ; + result + +ENDPROC params0 ; + + +TEXT PROC data representation (INT CONST data addr, segment, address, type) : + INT VAR stack offset, ds segment, ds number, ds address ; + TEXT VAR result ; + IF is data address + THEN IF local data address + THEN stack offset := data addr ; + rotate (stack offset, minus one) ; + stack offset := stack offset AND hex 3fff ; + IF local reference address OR type = ref addr + THEN get referenced representation + ELSE get representation from stack + FI + ELSE get representation from packet data + FI + ELSE object representation (minus one, data addr, segment, address, type) + FI . + +is data address : + NOT (type = 23 OR type = 9 OR type = 14) . + +local data address : + data addr < 0 . + +local reference address : + (data addr AND 1) = 1 . + +is runtime : + lbas <> minus one . + +get representation from packet data : + IF with object and address + THEN result := "" + ELSE result := "" + FI ; + result CAT object representation (packet data segment, data addr ADD data base, + segment, address, type) ; + result . + +get representation from stack : + result := "" ; + IF is runtime + THEN IF NOT with object and address + THEN result := "" + FI ; + result CAT object representation (local data segment, + lbas ADD stack offset, segment, address, type) + FI ; + result . + +get referenced representation : + IF is runtime + THEN ds address := getword (local data segment, lbas ADD stack offset) ; + ds number := getword (local data segment, lbas ADD stack offset ADD 1) ; + split word (ds number, ds segment) ; + IF ds number = standard dataspace + THEN IF with object and address + THEN result := "" + ELSE result := "" + FI ; + IF ds segment <= local data segment + THEN result CAT object representation (ds segment, + ds address, segment, address, type) + + ELIF ds segment > 3 (* Illegal! *) + THEN result := "" + ELSE (* PROC-Addresse *) + result CAT object representation (ds segment, + ds address, segment, address, mod addr) + FI ; + result + ELSE "" + FI + ELSE "" + FI . + +ENDPROC data representation ; + + +INT VAR anzahl zeros, anzahl steuerzeichen ; + +TEXT PROC object representation (INT CONST data segment, data address, + segment, address, type) : + TEXT VAR t, result ; + INT VAR i, zeichen, highbyte, lowbyte, first word ; + SELECT type OF + CASE try type,refaddr: try representation + CASE int addr : int representation + CASE real addr : real representation + CASE text addr : text representation + CASE dataspace addr : dataspace representation + CASE task addr : task representation + CASE mod addr : module address representation + CASE bool addr : bool representation + CASE int value : integer value + CASE hexbyte value : integer hexbyte + CASE module nr value : module nr representation + OTHERWISE "unbek. Typ: " + code (type + 63) + ENDSELECT . + +module nr representation : + text val := text (data address) ; + process module nr (data address) . + +bool representation : + IF getword (data segment, data address) = 0 + THEN text val := "TRUE" + ELSE text val := "FALSE" + FI ; + text val . + +reference address : + highbyte := getword (data segment, data address ADD 1) ; + splitword (highbyte, lowbyte) ; + result := "@" + hex8 (highbyte) + "-" + hex8 (lowbyte) ; + result CAT hex16 (getword (data segment, data address)) ; + text val := result ; + result . + +int representation : + i := get word (data segment, data address) ; + text val := text (i) ; + result := text (i) ; + IF i < 0 + THEN result CAT "|" ; + result CAT hex16 (i) ; + result CAT "H" + ELIF i >= 256 + THEN result CAT "|" ; + result CAT hex16 (i) ; + result CAT "H" ; + FI ; + result . + +integer value : + text val := text (data address) ; + text (data address) . + +integer hexbyte : + text val := text (data address) ; + IF (data address AND hex ff00) = 0 + THEN hex8 (data address) + "H" + ELSE hex16 (data address) + "H" + FI . + +real representation : + result := "12345678" ; + FOR i FROM 0 UPTO 3 REP + replace (result, i + 1, get word (data segment, data address ADD i)) + PER ; + disablestop ; + result := compress (text (result RSUB 1, 20)) ; + IF iserror + THEN clear error ; + result := "undefined REAL" + FI ; + text val := result ; + result . + +text representation : + t := copied text var (data segment, data 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 CAT """" ; + text val := result ; + result . + +task representation : + INT CONST index := get word (data segment, data address) , + version := get word (data segment, data address ADD 1) ; + IF index < 256 + THEN result := hex8 (index) + ELSE result := hex16 (index) ; + insertchar (result, "-", 3) + FI ; + result CAT "-" ; + result CAT hex16 (version) ; + result CAT "/" ; + result CAT taskname (index, version) ; + text val := result ; + result . + +dataspace representation : + highbyte := get word (data segment, data address) ; + splitword (highbyte, lowbyte) ; + result := hex8 (highbyte) ; + result CAT "-" ; + result CAT hex8 (lowbyte) ; + IF (highbyte AND lowbyte) = 255 + THEN result CAT ":not init" + ELIF (highbyte OR lowbyte) = 0 + THEN result CAT ":nilspace" + FI ; + text val := result ; + result . + +module address representation : + (* Hier: lowbyte = mod nr, highbyte = mod addr *) + next module header (data segment, data address, highbyte, lowbyte) ; + IF highbyte <> data address + THEN linear search (* Adresse muá doch zu finden sein *) + FI ; + text val := text (lowbyte) ; + process module nr (lowbyte) . + +linear search : + IF data segment = 2 + THEN FOR i FROM 512 UPTO 767 REP + IF getword (packet data segment, i) = data address + THEN lowbyte := i-512 ; + LEAVE linear search + FI + PER + ELSE FOR i FROM 1792 UPTO 3839 REP + IF getword (packet data segment, i) = data address + THEN lowbyte := i-512 ; + LEAVE linear search + FI + PER + FI ; (* Moduleaddress nicht gefunden, da stimmt doch was nicht! *) + LEAVE module address representation WITH reference address . + +try representation : + first word := getword (data segment, data address) ; + result := text (first word) ; + IF first word < 0 OR first word >= 256 + THEN result CAT "|" ; + result CAT hex16 (first word) ; + result CAT "H" + FI ; + IF first word = 0 + THEN result CAT "|TRUE" + ELIF first word = 1 + THEN result CAT "|FALSE" + FI ; + IF vorzeichen ok AND nur digits (* real *) + THEN result CAT "|" ; + disablestop ; + TEXT CONST txt :: compress (text (t RSUB 1, 20)) ; + IF is error + THEN clear error + ELSE result CAT txt + FI ; + FI ; + IF within compiler + THEN IF first word >= begin of stringtable CAND first word <= end of nametable + THEN string pointer (* first word wird ggf veraendert! *) + ELIF first word > 9 AND first word < 32 + THEN result CAT "|""""" + text (first word) + """""" (* Char *) + ELIF first word = 34 + THEN result CAT "|""""" + ELIF first word >= 32 AND first word < 127 + THEN result CAT "|""" + code (first word) + """" (* Code-Char *) + FI ; + ELIF text sinnvoll + THEN result CAT "|" ; + result CAT t + FI ; + text val := result ; + result . + +text sinnvoll : + keine steuerzeichen AND + (getword (data segment, data address ADD 1) AND 255) < 80 . + +within compiler : + segment = 2 AND ulseq (address, first elan address-1) . + +string pointer : + IF first word >= begin of name table + THEN first word INCR 2 + FI ; + IF (cdbint (first word) AND 255) < 100 + THEN t := cdbtext (first word) ; + IF pos (t, ""0"", ""31"", 1) = 0 CAND + pos (t, ""127"", ""213"", 1) = 0 CAND + pos (t, ""220"", ""255"", 1) = 0 + THEN result CAT "|""" ; + result CAT t ; + result CAT """" + FI + FI . + +keine steuerzeichen : + t := object representation (data segment, data address, + segment, address, text addr) ; + anzahl steuerzeichen < 4 AND anzahl zeros < 2 AND + getword (data segment, data address ADD 1) <> minus one . + +vorzeichen ok : + (first word AND hex f0) = 0 OR (first word AND hex f0) = 128 . + +nur digits : + t := "12345678" ; + FOR i FROM 0 UPTO 3 REP + replace (t, i + 1, get word (data segment, data address ADD i)) + PER ; + IF (first word AND 15) > 9 THEN FALSE + ELSE FOR i FROM 2 UPTO 7 REP + lowbyte := code (t SUB i) ; + IF (lowbyte AND hex f0) > 249 OR (lowbyte AND 15) > 9 + THEN LEAVE nur digits WITH FALSE + FI + PER ; + TRUE + FI . + +ENDPROC object representation ; + + +TEXT PROC process module nr (INT CONST module number) : + TEXT VAR object specification ; + was bool result := modules last word is bool return ; + IF is elan module number + THEN object specification := module name and specifications (module number) ; + IF object specification = "" + THEN object specification := "Hidden: PACKET " ; + object specification CAT packet name (module number) ; + IF was bool result + THEN object specification CAT " --> BOOL" + FI + ELSE was bool result := pos (object specification, "--> BOOL") > 0 ; + FI + ELIF one of compilers own module numbers + THEN object specification := "CDL (" ; + object specification CAT text ((getword (2, code address (module number)) - 4) DIV 2) ; + object specification CAT ")" ; + IF was bool result + THEN object specification CAT " --> BOOL" + FI + ELIF elan defined internal + THEN SELECT module number - 255 OF + CASE 1 : object specification := "compiler (INT CONST, FILE VAR, TEXT CONST, INT VAR, BOOL CONST ins, BOOL CONST lst, BOOL CONST rtc, BOOL CONST ser)" + CASE 2 : object specification := "outtext (TEXT CONST, INT CONST)" + CASE 3 : object specification := "outline (INT CONST)" + CASE 4 : object specification := "syntaxerror (TEXT CONST)" + CASE 5 : object specification := ":= (FILE VAR, FILE CONST)" + OTHERWISE object specification := "INTERNAL " + text (module number) + ENDSELECT + ELSE object specification := "Modulnummer ohne Code!" ; + was bool result := FALSE + FI ; + IF with object and address OR one of compilers own module numbers + THEN object specification CAT " (" ; + object specification CAT text (module number) ; + object specification CAT ":$" ; + object specification CAT text (code segment (module number)) ; + object specification CAT hex16 (code address (module number)) ; + object specification CAT ")" ; + FI ; + object specification . + +modules last word is bool return : + INT CONST last word :: getword (code segment (module number), + code address (module number + 1) SUB 1) ; + last word = rtnt opcode OR last word = rtnf opcode . + +one of compilers own module numbers : + module number < 244 . + +elan defined internal : + module number >= 256 AND module number < 272 . + +is elan module number : + module number >= 272 . + +ENDPROC process module nr ; + + +TEXT PROC copied text var (INT CONST segment, addr) : + TEXT VAR result, t ; + INT VAR laenge, first char, address, heap segment ; + address := addr ADD 1 ; + first char := getword (segment, address) ; + splitword (first char, laenge) ; + IF laenge = 0 + THEN "" + ELIF laenge = 255 + THEN copy text from heap + ELSE copy text from data segment + FI . + +copy text from data segment : + result := code (first char) ; + laenge DECR 1 ; + t := " " ; + INC address ; + WHILE laenge > 1 REP + replace (t, 1, getword (segment, address)) ; + result CAT t ; + laenge DECR 2 ; + INC address ; + PER ; + IF laenge = 1 + THEN result CAT code (getword (segment, address) AND 255) + FI ; + result . + +copy text from heap : + address := get word (segment, addr) ; + rotate (address, minus one) ; + heap segment := address AND 7 ; + address := address AND hex fff8 ; (* In Vielfachen von 8 *) + laenge := getword (segment, addr ADD 2) AND 255 ; + makeword (laenge, first char) ; (* 16 Bit Laenge ber Wortgrenze *) + laenge := min (laenge, 256) ; (* Mehr ist im Listing nicht sinnvoll *) + IF getword (heap segment, address) = minus one (* Standard DS *) + THEN address INCR 3 ; (* Kann nicht ber 8000H Grenze gehen *) + ELSE INC address (* Im Frei-Datenraum nur Wort Laenge *) + FI ; + result := "" ; + WHILE laenge > 1 REP + result CAT getword (heap segment, address) ; + laenge DECR 2 ; + INC address + PER ; + IF laenge = 1 + THEN result CAT code (getword (heap segment, address) AND 255) + FI ; + result . + +ENDPROC copied text var ; + + +PROC push (INT CONST a, b) : + INT VAR dummy1 := a, dummy2 := b +ENDPROC push ; + + +PROC pop (TASK VAR a, INT CONST dummy) : + TASK VAR x ; + a := x +ENDPROC pop ; + + +TEXT PROC task name (INT CONST id, vers) : + TASK VAR t ; + IF id = 0 + THEN "niltask" + ELSE push (id, vers) ; + pop (t, 0) ; + IF exists (t) + THEN """" + name (t) + """" + ELSE "-" + FI + FI +ENDPROC task name ; + + +ENDPACKET eumel decoder ; + + +(**************************************************************************) + +PACKET tracer DEFINES (* M. Staubermann *) + (* 20.04.86 *) + list breakpoints , (* 1.8.0, 861107 15:45 *) + set breakpoint , + reset breakpoint , + source file , + prot file , + tracer channel , + trace , + reset breakpoints : + +LET local base field = 25 , + packet data segment = 0 , + local data segment = 1 , + code segment 3 = 3 , + + 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 , + brcomp opcode = 32544 , + + ln opcode = 0 , + ln long opcode = 1024 , + call opcode = 30720 , + pcall opcode = 32543 , + + pp opcode = 27648 , + ppv opcode = 26624 , + pproc opcode = 32542 , + + rtn opcode = 32512 , + rtnt opcode = 32513 , + rtnf opcode = 32514 , + + hex 7f00 = 32512 ; + +INT CONST longa opcode :: -256 , + longa ppv opcode :: longa opcode + 104 , + longa pp opcode :: longa opcode + 108 , + hex 83ff :: -31745 , + minus one :: -1 ; + +LET nr of breakpoints = 2 , (* Max. Anzahl unvorhersehbare Verzweigungen/Branch *) + BREAKPOINT = STRUCT (BOOL set, INT address, saved word) ; + +ROW nr of breakpoints BREAKPOINT VAR breakpoints ; +BREAKPOINT CONST init breakpoint :: BREAKPOINT:(FALSE, -5, 0) ; + +FOR actual linenumber FROM 1 UPTO nr of breakpoints REP + breakpoints (actual line number) := init breakpoint +PER ; + + +BOOL VAR auto trace := FALSE , + forward trace := TRUE , + source lines neu := TRUE ; + +INT VAR previous instruction address , + prot file number , + trace channel := minus one , + actual line number := minus one , + handler module := 339 ; (* Dummy: PROC stop *) + +TEXT VAR prot file name := "" , + source line := "" , + source file name := "" ; + +FILE VAR source, protocoll ; + + +INT PROC tracer channel : + trace channel +ENDPROC tracer channel ; + + +PROC tracer channel (INT CONST c) : + IF c < 17 AND c > minus one + THEN trace channel := c + ELSE errorstop ("PROC tracer channel: Kanalnummer unzul„ssig") + FI +ENDPROC tracer channel ; + + +PROC trace : + TEXT VAR name ; + forward trace := TRUE ; + set breakpoint ; + get command ("PROC/OP-Aufruf eingeben:") ; + out (""13"") ; + put (" Sourcefilename (falls keine Sourcefile RETURN) :") ; + getline (name) ; + source file (name) ; + put (" Protokollfilename (falls kein Protokoll RETURN):") ; + getline (name) ; + prot file (name) ; + put (" Tracekanal (Ausfhrung an diesem Kanal: RETURN):") ; + name := "0" ; + editget (name) ; + line ; + tracer channel (int (name)) ; + do command + +ENDPROC trace ; + + +PROC source file (TEXT CONST file name) : + IF exists (file name) + THEN source := sequentialfile (modify, file name) ; + source file name := file name ; + 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 + ELSE source file name := "" + FI + +ENDPROC source file ; + + +TEXT PROC source file : + source file name +ENDPROC source file ; + + +TEXT PROC prot file : + prot file name +ENDPROC prot file ; + + +PROC prot file (TEXT CONST file name) : + IF file name = "" + THEN prot file name := "" + ELSE forget (file name, quiet) ; + prot file number := 0 ; + protocoll := sequentialfile (output, file name) ; + max line length (protocoll, 1000) ; + prot file name := file name ; + FI +ENDPROC prot file ; + + +PROC protocoll line : + IF prot file name <> "" + THEN line (protocoll) ; + IF lines (protocoll) > 4000 + THEN prot file number INCR 1 ; + TEXT CONST file name :: prot file name + "." + + text (prot file number) ; + putline (protocoll, "Fortsetzung in Datei " + file name) ; + forget (file name, quiet) ; + protocoll := sequentialfile (output, file name) ; + max line length (protocoll, 1000) + FI + FI + +ENDPROC protocoll line ; + + +PROC write protocoll (TEXT CONST t) : + IF prot file name <> "" + THEN write (protocoll, t) + FI +ENDPROC write protocoll ; + + +PROC breakpoint handler : + + ROW 32 INT VAR offset fuer inter call stack variablen ; + BOOL VAR was bool result , + ueberschrift neu , + code lines neu ; + TEXT VAR key, previous key, + old error message , + statement line, opcode, + previous opcode, next opcode ; + INT VAR i, x, y , + actual opcode, actual word, op word, next instruction, + following word, saved word, + lbas, this local base, st ptr, + old channel, old error code, old error line, + user address, branch address, address, + lowbyte, + c8k, packet base, + actual instruction address, previous actual address, + next instruction address, + return segment, return address, + breakpoint address, breakpoint nr ; + + determine return address and breakpoint nr ; + reset breakpoints ; + getcursor (x, y) ; + next instruction address := breakpoint address ; + IF NOT forward trace AND previous instruction address <> minus one + THEN decode instruction (previous instruction address, previous actual address, + previous opcode, FALSE) ; + ELSE previous opcode := "" + FI ; + decode instruction (next instruction address, actual instruction address, + next opcode, TRUE) ; + was bool result := bool result ; + IF forward trace + THEN write protocoll (" " + hex16 (actual instruction address) + " ") ; + write protocoll (next opcode) ; + protocoll line + ELSE write protocoll ("*" + hex16 (previous actual address) + " ") ; + write protocoll (previous opcode) ; + protocoll line + FI ; + actual word := getword (code segment 3, actual instruction address) ; + actual opcode := actual word AND opcode mask ; + following word := getword (code segment 3, actual instruction address ADD 1) ; + next instruction := getword (code segment 3, next instruction address) ; + out (""1""10""5""10""5"") ; + IF NOT auto trace + THEN out (""6""6""0"") ; + putline ("Auto, Bpnt, Clrr, Dstp, Estp, File, Go, Prot, Rslt, Step(CR), Term, - + < >"5"") ; + putline ("------------------------------------------------------------------------------"5"") ; + FI ; + ueberschrift neu := TRUE ; + code lines neu := TRUE ; + previous key := "" ; + REP + kopf 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"abcdefgprst +-<>", key) > 0 PER ; + IF key >= "a" + THEN key := code (code (key)-32) + FI ; + analyze key + FI ; + previous key := key + UNTIL pos ("GST!", key) > 0 PER ; + IF key <> "T" + THEN execute saved instruction + FI ; + IF key = "T" + THEN write protocoll (" Terminated") ; + protocoll line ; + resetbreakpoints ; + term + ELIF key = "G" + THEN write protocoll (" Go") ; + protocoll line + ELIF key = "S" + THEN singlestep + FI ; + previous instruction address := breakpoint address ; + cursor (x, y) ; + IF trace channel > 0 + THEN IF old channel = 0 + THEN break (quiet) + ELSE continue (old channel) + FI + FI ; + IF bit (return segment, 7) + THEN disablestop ; + set line nr (old error line) ; + error stop (old error code, old error message) ; + set line nr (0) + FI . + +analyze key : + IF previous key = "B" + THEN IF key = ""13"" OR key = "S" (* Sicherheitsabfrage *) + THEN key := "!" ; (* Exit-Key *) + write protocoll (" Skip") ; + protocoll line ; + write protocoll (" " + hex16 (user address) + " ") ; + write protocoll (opcode) ; + protocoll line ; + set breakpoint (breakpoint nr, user address) + ELSE code lines neu := TRUE + FI + ELIF key = ""13"" + THEN key := "S" + ELIF key = " " + THEN code lines neu := TRUE ; + source lines neu := TRUE ; + ueberschrift neu := TRUE ; + ELSE SELECT code (key)-43 OF (* Um die Anzahl Branches klein zu halten*) + CASE 0 {+} : stptr := stptr ADD 2 ; + ueberschrift neu := TRUE + CASE 2 {-} : stptr := stptr SUB 2 ; + ueberschrift neu := TRUE + CASE 17 {<} : with object address (TRUE) ; + IF forward trace + THEN decode instruction (breakpoint address, + actual instruction address, next opcode, FALSE) + ELIF previous instruction address <> minus one + THEN decode instruction (previous instruction address, + previous actual address, previous opcode, FALSE) + FI ; + code lines neu := TRUE + CASE 19 {>} : with object address (FALSE) ; + IF forward trace + THEN decode instruction (breakpoint address, + actual instruction address, next opcode, FALSE) + ELIF previous instruction address <> minus one + THEN decode instruction (previous instruction address, + previous actual address, previous opcode, FALSE) + FI ; + code lines neu := TRUE ; + CASE 22 {A} : auto trace := TRUE ; + key := "S" + CASE 23 {B} : get breakpoint address from user + CASE 24 {C} : resetbit (return segment, 7) ; + ueberschrift neu := TRUE + CASE 25 {D} : setbit (return segment, 6) ; + ueberschrift neu := TRUE + CASE 26 {E} : resetbit (return segment, 6) ; + ueberschrift neu := TRUE + CASE 27 {F} : out (""6""5""0"Sourcefile:"5"") ; + editget (source file name) ; + source file (source file name) ; + ueberschrift neu := TRUE ; + source lines neu := TRUE + CASE 37 {P} : out (""6""5""0"Protokollfile:"5"") ; + editget (prot file name) ; + prot file (prot file name) + CASE 39 {R} : forward trace := NOT forward trace ; + IF NOT forward trace AND previous opcode = "" AND + previous instruction address <> minus one + THEN decode instruction (previous instruction address, + previous actual address, previous opcode, FALSE) + FI ; + ueberschrift neu := TRUE ; + code lines neu := TRUE + ENDSELECT + FI . + +kopf schreiben : + out (""6""5""0""5"") ; + IF ueberschrift neu + THEN schreibe ueberschrift ; + ueberschrift neu := FALSE + FI ; + IF source lines neu + THEN schreibe source lines ; + source lines neu := FALSE + FI ; + IF code lines neu + THEN IF forward trace + THEN show decoded opcode (next opcode, + actual instruction address, TRUE, TRUE) + ELIF previous instruction address <> minus one + THEN show decoded opcode (previous opcode, + previous actual address, TRUE, TRUE) + ELSE out (""6""5""0"Kein vorhergehender Befehl") + FI ; + code lines neu := FALSE + FI . + +schreibe ueberschrift : + out (""1"") ; + put (breakpoint nr) ; + IF forward trace + THEN put ("F") (* forward *) + ELSE put ("R") (* result *) + FI ; + IF bit (return segment, 4) + THEN out ("u") (* ARITHU *) + ELSE out ("s") + FI ; + IF bit (return segment, 6) + THEN out ("d") (* Disablestop *) + ELSE out ("e") + FI ; + IF bit (return segment, 7) + THEN put ("E") (* iserror *) + ELSE put (" ") + FI ; + put ("lbas:") ; put (hex16 (lbas)) ; + out ("stack(") ; out (hex16 (stptr)) ; put ("):") ; + out (hex16 (getword (local data segment, stptr))) ; out ("-") ; + put (hex16 (getword (local data segment, stptr ADD 1))) ; + put ("pbas:") ; put (hex8 (packet base)) ; + put ("c8k:") ; put (hex8 (c8k)) ; + IF valid source + THEN out ("""") ; outsubtext (source file name, 1, 19) ; put ("""") + FI ; + out (""5"") . + +schreibe source lines : + out (""1""10"") ; + IF valid source AND source line <> "" + THEN put (text (actual line number, 4)) ; + put ("|") ; + outsubtext (source line, 1, 72) ; + out (""5"") ; + line ; + IF LENGTH source line <= 72 + THEN put (text (actual line number +1, 4)) ; + put ("|") ; + toline (source, actual line number +1) ; + out (subtext (source, 1, 72)) ; + out (""5"") ; + toline (source, actual line number) ; + line + ELSE put ("_____|") ; + outsubtext (source line, 73, 144) ; + out (""5"") ; + line + FI + FI . + +valid source : + exists (source file name) . + +get breakpoint address from user : + put ("N„chste Breakpointaddresse (hex) in Segment 3:") ; + statement line := hex16 (next instruction address) ; + editget (statement line) ; + user address := integer (statement line) ; + opcode := "" ; + statement line := "" ; + address := user address ; + bool result (FALSE) ; + decode (code segment 3, address, statement line, + opcode, INT PROC (INT CONST, INT VAR, TEXT VAR) next word) ; + show decoded opcode (opcode, user address, TRUE, TRUE) ; + code lines neu := FALSE . + +singlestep : + IF is return opcode + THEN set breakpoint behind previous call + ELIF was bool result AND NOT is call opcode + THEN set first breakpoint behind branch instruction ; + set second breakpoint at branch address + 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 brcomp opcode + THEN set computed branch breakpoint + ELIF is branch instruction + THEN set breakpoint at branch address + ELIF is call opcode AND NOT auto trace CAND segment 3 module CAND + ask if subroutine trace + THEN write protocoll (" Subroutine Trace") ; + protocoll line ; + calculate subroutine segment and address ; + set breakpoint behind next instruction + ELSE set breakpoint behind next instruction + FI . + +ask if subroutine trace : + IF forward trace + THEN yes (""6""5""0"Subroutine Trace") + ELSE show decoded opcode (next opcode, actual instruction address, FALSE, FALSE) ; + yes (""6""6""0"Subroutine Trace"5"") + FI . + +is line number : + actual opcode = ln opcode OR (* Kein LONGA, da ln < 4095 *) + actual opcode = lnlong opcode . + +is branch instruction : + actual opcode = br opcode OR + actual opcode = brlong opcode . + +is conditional branch : + op word = bf opcode OR op word = bflong opcode OR + op word = bt opcode OR op word = btlong opcode . + +is brcomp opcode : + actual word = brcomp opcode . + +is return opcode : + actual word = rtn opcode . + +is bool return opcode : + actual word = rtnt opcode OR + actual word = rtnf opcode . + +is call opcode : + actual opcode = call opcode OR + actual word = pcall opcode . + +read source line : + actual line number := actual word ; + split word (actual line number, lowbyte) ; + actual line number := (actual line number * 2) AND 6 ; + IF actual word < 0 + THEN actual line number INCR 1 + FI ; + IF actual opcode = lnlong opcode + THEN actual line number INCR 8 + FI ; + makeword (actual line number, lowbyte) ; + actual line number DECR 1 ; + source lines neu := TRUE ; + 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 is conditional branch + THEN write protocoll (" ") ; + write protocoll (hex16 (next instruction address) + " ") ; + bool result (TRUE) ; + statement line := "" ; + opcode := "" ; + address := next instruction address ; + decode (code segment 3, next instruction address, statement line, opcode, + INT PROC (INT CONST, INT VAR, TEXT VAR) next word) ; + write protocoll (opcode) ; + protocoll line ; + show decoded opcode (opcode, address, FALSE, FALSE) ; + IF NOT auto trace + THEN pause (20) + FI ; + next free breakpoint ; + set breakpoint (i, next instruction address) ; + ELSE putline ("Interner Fehler: Nach BOOL-Result folgt kein Branch"5""); + LEAVE singlestep + FI . + +set second breakpoint at branch address : + calculate branch address ; + next free breakpoint ; + set breakpoint (i, branch address) . + +set breakpoint at branch address : + next instruction := actual word ; + next instruction address := actual instruction address ; + calculate branch address ; + set breakpoint (breakpoint nr, branch address) . + +set first breakpoint behind branch instruction at return address : + IF (getword (local data segment, lbas + return segment offset) AND 7) = code segment 3 + THEN next instruction address := getword (local data segment, + lbas + return address offset) ; + next instruction := getword (code segment 3, next instruction address) ; + c8k := getword (local data segment, lbas + c8k offset) AND 255 ; + set first breakpoint behind branch instruction + ELSE putline ("Trace bei Vorw„rtssprung beendet."5"") + FI . + +set second breakpoint at branch address of branch instruction at return address : + set second breakpoint at branch address . + +set computed branch breakpoint : + address := following word ; + IF address < 0 (* Local/Local Ref *) + THEN rotate (address, minus one) ; + address := (address AND 16 383) ADD lbas ; + IF bit (following word, 0) + THEN branch address := getword (getword (local data segment, + address ADD 1) AND 7, + getword (local data segment, + address)) + ELSE branch address := getword (local data segment, address) + FI + ELSE branch address := getword (packet data segment, + address ADD packet base) + FI ; + IF switch out of range + THEN branch address := actual instruction address ADD 3 + ELSE branch address := actual instruction address ADD branch address ADD 4 + FI ; + set breakpoint (breakpoint nr, branch address) . + +switch out of range : + branch address < 0 OR + branch address > getword (code segment 3, actual instruction address ADD 2) . + +determine return address and breakpoint nr : + FOR x FROM 1 UPTO 10 REP + determine return address ; + determine breakpoint nr ; + PER ; + line ; + put ("Returnaddresse nicht gefunden:"5"") ; + out (text (return segment AND 3)) ; + putline (hex16 (return address)) ; + list breakpoints ; + reset breakpoints ; + enablestop ; + errorstop ("Falsche Returnaddresse") . + +determine return address : + fix local base ; (* Fix pcb's: RAM --> Leitblock *) + this local base := getword (local data segment, pcb (local base field)) ; + 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 ; (* Wort besteht aus zwei Teilen!*) + set parameters (lbas, packet base, minus one, c8k) ; + stptr := lbas ADD 4 ; + DEC return address ; (* auf CALL breakpointhandler (ein Wort zurck) *) + IF bit (return segment, 7) (* ISERR *) + THEN old error line := error line ; + old error code := error code ; + old error message := error message + FI ; + clear error ; + enablestop ; + IF trace channel > 0 AND trace channel <> channel + THEN old channel := channel ; + disablestop ; + continue (trace channel) ; + clear error ; + enablestop + FI . + +determine breakpoint nr : + FOR i FROM 1 UPTO nr of breakpoints REP + IF breakpoints (i).set CAND + breakpoints (i).address = return address + THEN breakpoint nr := i ; + breakpoint address := breakpoints (i).address ; + saved word := breakpoints (i).saved word ; + LEAVE determine return address and breakpoint nr + FI + PER . + +segment 3 module : + IF actual word = pcall opcode + THEN op word := following word ; + rotate (op word, minus one) ; + op word := (op word AND 16 383) ADD lbas ; + LEAVE segment 3 module WITH (getword (local data segment, + op word ADD 1) AND 7) = code segment 3 + ELSE op word := actual word AND 1023 ; + IF actual word < 0 + THEN op word INCR 1024 + FI ; + FI ; + op word >= 1280 . + +calculate subroutine segment and address : + IF actual word = pcall opcode + THEN next instruction address := getword (local data segment, op word) + ELSE next instruction address := getword (packet data segment, + begin of module nr link table + op word) + FI ; + INC next instruction address . (* Ab PENTER tracen *) + +calculate branch address : + branch address := next instruction ; + split word (branch address, low byte) ; + branch address := (branch address * 2) AND 6 ; + IF next instruction < 0 + THEN branch address INCR 1 + FI ; + IF branch long + THEN branch address INCR 8 + FI ; + branch address INCR HIGH next instruction address ; + IF branch address >= c8k + THEN branch address DECR 16 + FI ; + makeword (branch address, lowbyte) . + +branch long : + bit (next instruction, 10) . + +execute saved instruction : + putword (local data segment, this local base + return address offset, + return address) ; + putword (local data segment, this local base + return segment offset, + return segment) . + + +set breakpoint behind next instruction : + IF is line number THEN read source line FI ; + set breakpoint (breakpoint nr, 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 = code segment 3 + THEN set breakpoint (breakpoint nr, return address) + ELSE putline ("Trace bei Rcksprung beendet."5"") + 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 ("Alle " + text(nr of breakpoints) + " Breakpoints sind belegt"5"") ; + LEAVE singlestep + +ENDPROC breakpoint handler ; + + +PROC show decoded opcode (TEXT CONST opcode, INT CONST address, + BOOL CONST zweizeilig, oben) : + IF oben + THEN out (""6""3""0"") + ELSE out (""6""5""0"") + FI ; + put (hex16 (address)) ; + put ("|") ; + outsubtext (opcode, 1, 72) ; + out (""5"") ; + line ; + IF zweizeilig + THEN put (" |") ; + outsubtext (opcode, 73, 144) ; + out (""5"") ; + line + FI + +ENDPROC show decoded opcode ; + + +PROC decode instruction (INT VAR address, actual address, TEXT VAR opcode, + BOOL CONST var) : + + INT VAR actual word, actual opcode, temp address ; + TEXT VAR statement line := "" ; + opcode := "" ; + temp address := address ; + actual address := address ; + actual word := getword (code segment 3, temp address) ; + actual opcode := actual word AND opcode mask ; + bool result (FALSE) ; + IF is param push opcode + THEN opcode := module with actual params (temp address, actual address) ; + ELSE decode (code segment 3, temp address, + statement line, opcode, + INT PROC (INT CONST, INT VAR, TEXT VAR) next word) ; + FI ; + IF var THEN address := temp address FI . + +is param push opcode : + actual opcode = pp opcode OR + actual word = pproc opcode OR + actual word = longa pp opcode OR + actual word = longa ppv opcode OR + actual opcode = ppv opcode . + +ENDPROC decode instruction ; + + +TEXT PROC module with actual params (INT VAR address, actual address) : + + TEXT VAR result, statement line, symbol, type text ; + INT VAR end address, start address := address, module nr, + actual word, actual opcode ; + BOOL VAR known paramtypes, was bool result ; + + skip until next call opcode ; + determine module name and module nr ; + collect actual parameters ; + perhaps result type ; + bool result (was bool result) ; + address := end address ; + result . + +skip until next call opcode : + actual word := getword (code segment 3, address) ; + REP + IF (actual word AND hex 7f00) = hex 7f00 (* LONGA oder ESC *) + THEN INC address + FI ; + INC address ; + actual word := getword (code segment 3, address) ; + actual opcode := actual word AND opcode mask ; + UNTIL is call opcode PER . + +determine module name and module nr : + result := "" ; + statement line := "" ; + actual address := address ; (* Addresse des CALL/PCALL Befehls *) + decode (code segment 3, address, statement line, result, + INT PROC (INT CONST, INT VAR, TEXT VAR) next word) ; + was bool result := bool result ; + bool result (FALSE) ; + end address := address ; + module nr := int (last actual parameter) ; + statement line := module name and specifications (module nr) ; + scan (statement line) ; + IF statement line = "" + THEN symbol := "(" ; + known paramtypes := FALSE ; + actual word := getword (code segment 3, start address) ; + actual opcode := actual word AND opcode mask ; + IF is call opcode (* Hidden ohen Result und Parameter *) + THEN LEAVE module with actual params WITH result + ELSE result CAT " (" (* Result wird als VAR Parameter betr.*) + FI + ELSE nextsymbol (symbol) ; (* Skip Name *) + nextsymbol (symbol) ; + known paramtypes := TRUE ; + IF symbol = "" (* Weder Parameter, noch Result *) + THEN LEAVE module with actual params WITH result + ELIF symbol = "(" + THEN result := subtext (result, 1, pos (result, "(")) ; + ELSE result := subtext (result, 1, pos (result, "-->")-2) + FI ; + FI ; + address := start address . (* Rcksetzen auf ersten param push *) + +collect actual parameters : + IF symbol <> "(" + THEN LEAVE collect actual parameters + FI ; + REP + nextsymbol (symbol) ; + IF symbol = "ROW" + THEN typetext := "ROW..." ; + nextsymbol (symbol) ; (* ROW-Size *) + skip until end of type (symbol) ; + ELIF symbol = "STRUCT" + THEN typetext := "STRUCT..." ; + nextsymbol (symbol) ; + skip over brackets (symbol) ; + ELIF symbol = "<" (* HIDDEN *) + THEN typetext := "" ; + nextsymbol (symbol) ; + nextsymbol (symbol) ; + nextsymbol (symbol) ; + ELIF symbol <> "PROC" + THEN typetext := symbol ; + nextsymbol (symbol) + FI ; (* symbol jetzt 'PROC', 'CONST' oder 'VAR' *) + IF getword (code segment 3, address) = pproc opcode + THEN result CAT "PROC " ; + type text := "" ; + decode (code segment 3, address, statement line, type text, + INT PROC (INT CONST, INT VAR, TEXT VAR) next word) ; + result CAT subtext (type text, 13) ; + next symbol (symbol) ; + IF symbol = "(" THEN skip over brackets (symbol) FI + ELSE IF statement line <> "" (* Keine Hidden PROC *) + THEN result CAT typetext ; + result CAT " " ; + result CAT symbol ; (* CONST oder VAR *) + result CAT ":" ; + typetext := ":" + typetext ; (* Fr Pos-Suche *) + nextsymbol (symbol) ; (* Jetzt auf ',' oder ')' *) + FI ; + IF (getword (code segment 3, address) AND hex 7f00) = hex 7f00 (* ESC OR LONGA *) + THEN result CAT data representation (getword (code segment 3, + address ADD 1), code segment 3, address, object type) ; + INC address + ELSE result CAT data representation (getword (code segment 3, address) + AND hex 83ff, code segment 3, address, object type) + FI ; + INC address + FI ; + actual word := getword (code segment 3, address) ; + actual opcode := actual word AND opcode mask ; + IF symbol <> ")" AND NOT is call opcode + THEN result CAT ", " + FI ; + UNTIL symbol = ")" OR is call opcode PER ; + result CAT ")" . + +perhaps result type : + WHILE symbol <> "" REP nextsymbol (symbol) UNTIL symbol = ">" PER ; (* --> *) + IF symbol <> "" + THEN nextsymbol (symbol) ; + IF symbol = "ROW" + THEN symbol := "ROW..." ; + ELIF symbol = "STRUCT" + THEN symbol := "STRUCT..." ; + ELIF symbol = "<" (* HIDDEN *) + THEN symbol := "" ; + FI ; + type text := ":" ; + type text CAT symbol ; + result CAT " --> " ; + result CAT symbol ; + IF symbol = "BOOL" (* BOOl-Result nicht mit PP *) + THEN LEAVE perhaps result type + FI ; + result CAT ":" ; + IF (getword (code segment 3, address) AND hex 7f00) = hex 7f00 (* ESC OR LONGA *) + THEN result CAT data representation (getword (code segment 3, + address ADD 1), code segment 3, address, object type) ; + INC address + ELSE result CAT data representation (getword (code segment 3, address) + AND hex 83ff, code segment 3, address, object type) + FI ; + INC address + FI . + +object type : + IF known paramtypes + THEN INT CONST p := pos (types, type text) ; + IF p = 0 + THEN 0 (* Try Type auch bei STRUCT/ROW *) + ELSE code (types SUB (p-1))-63 + FI + ELSE 0 (* Try all types *) + FI . + +types : + "B:BOOL I:INT R:REAL S:TEXT T:TASK D:DATASPACE D:FILE S:THESAURUS" . + +is call opcode : + actual opcode = call opcode OR + actual word = pcall opcode . + +ENDPROC module with actual params ; + + +PROC skip until end of type (TEXT VAR symbol) : + nextsymbol (symbol) ; + IF symbol = "ROW" + THEN nextsymbol (symbol) ; (* ROW-Size *) + skip until end of type (symbol) + ELIF symbol = "STRUCT" + THEN next symbol (symbol) ; + skip over brackets (symbol) + ELSE nextsymbol (symbol) (* steht auf ',' oder ')' *) + FI + +ENDPROC skip until end of type ; + + +PROC skip over brackets (TEXT VAR symbol) : + REP + next symbol (symbol) ; + IF symbol = "(" THEN skip over brackets (symbol) FI + UNTIL symbol = ")" PER ; + nextsymbol (symbol) + +ENDPROC skip over brackets ; + + +INT OP HIGH (INT CONST word) : + INT VAR highbyte := word, lowbyte ; + split word (highbyte, lowbyte) ; + highbyte + +ENDOP HIGH ; + + +PROC fix local base : + (* Kein direkter EXTERNAL-Aufruf, da bei 'CALL' lbas auf Stack gelegt wird*) + REP UNTIL incharety = "" PER ; (* Damit pause ausgefhrt wird *) + internal pause (0) (* ^ War Grund fr 'falsche Returnaddresse'*) + +ENDPROC fix local base ; + + +PROC reset breakpoints : + INT VAR i ; + 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 (code segment 3, breakpoints (nr).address, breakpoints (nr).saved word) ; + breakpoints (nr) := init breakpoint + FI + +ENDPROC reset breakpoint ; + + +PROC set breakpoint (INT CONST nr, 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") + ELSE breakpoints (nr).address := address ; + breakpoints (nr).saved word := get word (code segment 3, address) ; + new word := call opcode + (handler module AND 1023) ; + IF handler module >= 1024 + THEN setbit (new word, 15) + FI ; + putword (code segment 3, address, new word) ; + IF getword (code segment 3, 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 ; + + +INT PROC module number (PROC proc) : + + EXTERNAL 35 + +ENDPROC module number ; + + +PROC internal pause (INT CONST time) : + + EXTERNAL 66 + +ENDPROC internal pause ; + + +PROC term : + + EXTERNAL 4 + +ENDPROC term ; + + +PROC set breakpoint : + INT VAR i ; + handlers module nr (module number (PROC breakpointhandler)) ; + auto trace := FALSE ; + source lines neu := TRUE ; (* Zum L”schen *) + source file ("") ; + prot file ("") ; + actual line number := minus one ; + previous instruction address := minus one ; + with object address (FALSE) ; + INT VAR module nr ; + add modules ; + get module number (module nr) ; + IF code segment (module nr) <> code segment 3 + THEN errorstop ("PROC/OP liegt nicht im Codesegment 3") + FI ; + 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 address (module nr) ADD 1) ; + LEAVE naechsten freien breakpoint setzen + FI + PER ; + errorstop ("Alle " + text (nr of breakpoints) + " Breakpoints sind belegt"). + +ENDPROC set breakpoint ; + + +PROC list breakpoints : + INT VAR header address, mod nr, i ; + + line ; + putline (" Nr Set Address Word Module") ; + FOR i FROM 1 UPTO nr of breakpoints REP + put (text (i, 2)) ; + IF breakpoints (i).set + THEN put (" Y ") + ELSE put (" N ") + FI ; + out ("3") ; + put (hex16 (breakpoints (i).address)) ; + put (" ") ; + put (hex16 (breakpoints (i).saved word)) ; + IF breakpoints (i).set + THEN next module header (code segment 3, breakpoints (i).address, + header address, mod nr) ; + IF module name and specifications (modnr - 1) = "" + THEN put ("Hidden: PACKET") ; put (packet name (modnr -1)) ; + ELSE put (module name and specifications (modnr -1)) + FI + FI ; + line + PER + +ENDPROC list breakpoints ; + +ENDPACKET tracer ; + +init module table ("table.module") ; +type (""27"q") ; +note ("") ; 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 " " + 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 + -- cgit v1.2.3