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