path: root/lang/dynamo/1.8.7/src/dyn.rts

PACKET rts
 DEFINES constant, vdt, get pltper, get prtper, was print,
         println, print output, plot output, print line,
         sys page, pagefeed necessary, print suppressed output, asterisk,
         protokoll, default, set pagelength, run time system, b stop request,
         scroll, run card :
 (* Runtime - System *)
 (* Autor : R. Keil                                             *)
 (* Datum : 12.07.83     Aenderung: 19.06.84   D. Craemer       *)
 (*                    2.Aenderung:  6.05.85   D. Craemer       *)
 (* Änderung auf 1.8.2: Z. 288, Christian Szymanski, 10.08.88   *)
 (* In der 2. Aenderung wurde dyn.const in zzdyn.const umbenannt*)
 (* und alle Konstanten-Datenraeume bekommen ".const" angehaengt*)
 (* Wird im rts das Kommando   run name  gegeben, so wird der   *)
 (* augenblickliche Konstanten-Datenraum gerettet im Datenraum  *)
 (* mit dem Namen:            "name.const"                      *)


 
    LET esc           = ""27"",
    max tab size  = 50,
    bold          = 1,
    number        = 2,
    delimiter     = 3;

TYPE CONSTANT = STRUCT (ROW max tab size TEXT name,
                        ROW max tab size REAL value,
                        INT tab size);

BOUND CONSTANT VAR constants;

FILE VAR sysout;
TEXT VAR print buf, asterisk buffer, sym, const name,
         const space name::"zzdyn.const";
REAL VAR dt, length, prtper, pltper;
INT VAR line no, page no, max pagelength, type;

BOOL VAR vdt on, print, protocoll, terminal stop, is scroll,
         is not first, run specified;

 
default;
 
PROC default :
 protocoll      := FALSE;
 max pagelength := 23;
 is scroll      := TRUE;
 run specified  := FALSE
END PROC default;
 
PROC set pagelength (INT CONST i) :
 max pagelength := i
END PROC set pagelength;
 
PROC run card (TEXT CONST run name) :
 IF exists (actual constants)
  THEN constants := old (actual constants)
  ELIF run name="zzdyn"
  THEN constants := new (actual constants);
       CONCR (constants).tab size := 0
  ELSE copy (const space name, actual constants); 
       constants := old (actual constants)
 FI;
 const space name := actual constants.

 actual constants:
    run name + ".const".

END PROC run card;
 
REAL PROC constant (TEXT CONST name, REAL CONST val) :
 REAL VAR value;
 INT VAR tab pos;
 value := actual value;
 set system consts.

 actual value :
  search constant (name, tab pos);
  IF tab pos > 0
   THEN CONCR (constants).value (tab pos)
   ELSE new constant (name, val);
        val
  FI.

 set system consts :
  SELECT pos ("dt length prtper pltper ", name + " ") OF
   CASE 1  : dt     := value
   CASE 4  : length := value
   CASE 11 : prtper := value
   CASE 18 : pltper := value
  END SELECT;
  value.
END PROC constant;
 
PROC new constant (TEXT CONST name, REAL CONST val) :
 CONCR (constants).tab size INCR 1;
 IF CONCR (constants).tab size > max tab size
  THEN errorstop ("ZUVIELE KONSTANTEN")
 FI;
 CONCR (constants).name  (CONCR (constants).tab size) := name;
 CONCR (constants).value (CONCR (constants).tab size) := val
END PROC new constant;

PROC search constant (TEXT CONST name, INT VAR tab pos) :
 INT VAR i;
 FOR i FROM 1 UPTO CONCR (constants).tab size REP
  IF name = CONCR (constants).name (i)
   THEN tab pos := i;
        LEAVE search constant
  FI
 END REP;
 tab pos := 0
END PROC search constant;

REAL PROC get pltper :  (* Reicht 'pltper' (Plotperiode) heraus *)
 pltper
END PROC get pltper;
 
REAL PROC get prtper :  (* Reicht 'prtper' (Printperiode) heraus *)
 prtper 
END PROC get prtper;
 
PROC scroll (BOOL CONST b) :
 is scroll := b
END PROC scroll;
 
PROC next sym :
 next sym (sym, type)
END PROC next sym;

PROC rts err (TEXT CONST err mess) :
 outline ("FEHLER BEI >>>" + sym + "<<< : " + err mess)
END PROC rts err;

PROC run time system (PROC target program) :
 IF protocoll
  THEN kill ("dyn.out");
       sysout := sequential file (output, "dyn.out")
 FI;
 init rts;
 REP
  get command;
  execute command
 END REP.
 
 get command :
  TEXT VAR command;
  print suppressed output;
  line;
  putline ("      dynamo runtime system :");
  shift;
  getline (command);
  printline (command).

 execute command :
  scanner (command);
  next sym;
  TEXT VAR start := sym;
  skip blanks;
  SELECT pos ("run rerun quit help c ? EOL ", start + " ") OF
   CASE 1, 5 : run
   CASE 11   : quit
   CASE 16   : show ("dyn.help")
   CASE 21   : const equ
   CASE 23   : dump consts
   CASE 25   :
   OTHERWISE : rts err ("KOMMANDO UNBEKANNT")
  END SELECT.

 run :
  init rts;
  IF type = bold OR type = delimiter
   THEN run card (sym)
  FI;
  target program.

 quit :
  IF const space name = "zzdyn.const"
   THEN kill (const space name)
  FI;
  LEAVE runtime system.

 skip blanks :
  REP
   next sym
  UNTIL sym <> " " END REP.

 const equ :
  REAL VAR value, dummy;
  INT VAR tab pos;
  REP
   analyze constant equ;
   search constant (const name, tab pos);
   IF tab pos = 0
    THEN sym := const name;
         rts err ("KONSTANTE NICHT DEFINIERT")
    ELSE CONCR (constants).value (tab pos) := value
   FI
  UNTIL end of constants END REP.

 analyze constant equ :
  IF type <> bold
   THEN rts err ("NAME ERWARTET")
  FI;
  const name := sym;
  next sym;
  IF sym <> "="
   THEN rts err ("^=^ ERWARTET")
  FI;
  get constant.

 end of constants :
  next sym;
  IF sym = "/" OR sym = ","
   THEN next sym; FALSE
   ELSE TRUE
  FI.

 get constant :
  next sym;
  value := 1.0;
  IF sym = "-" 
   THEN value := -1.0; next sym
  ELIF sym = "+"
   THEN next sym
  FI;
  IF type = number
   THEN value := value * real (sym)
   ELSE rts err ("ZAHL ERWARTET")
  FI.

 dump consts :
  INT VAR i;
  FOR i FROM 1 UPTO CONCR (constants).tab size REP
   IF (i MOD 2) = 1
    THEN line; shift
   FI;
   out (text (CONCR (constants).name (i), 14),  " = ",
        text (text (CONCR (constants).value (i)), 13))
  END REP;
  line.
END PROC run time system;
 
PROC shift :
 out ("      ")
END PROC shift;

PROC init rts :
 line no         := 0;
 page no         := 0;
 asterisk buffer := "";
 print buf       := "";
 print           := FALSE;
 terminal stop   := FALSE;
 is not first    := FALSE;
 vdt on          := TRUE
END PROC init rts;

PROC protokoll (BOOL CONST b) :
 protocoll := b
END PROC protokoll;
 
PROC print line :
 BOOL VAR b := print;         (* Druckt Ausgabe - Puffer und *)
 println (print buf);         (* loescht anschliessend den Inhalt *)
 print buf := "";
 print := b
END PROC print line;
 
PROC print suppressed output :
 IF print buf <> ""           (* Druckt Ausgabe - Puffer, *)
  THEN println (print buf);   (* falls gefuellt *)
       print buf := ""
 FI
END PROC print suppressed output;
 
PROC print output (TEXT CONST t) :
 print buf CAT t;             (* Fuellt Ausgabe - Puffer *)
 print buf CAT " "
END PROC print output;
 
PROC println (TEXT CONST t) :
 print := TRUE;               (* Verteilt Ausgabe auf Bildschirm *)
 line no INCR 1;              (* und Datei *)
 outline (t);
 IF line no = max page length
  THEN line no := 0
 FI;
 IF is getcharety (esc)          (* bis einschl. 1.8.1: 'is incharety' *)
  THEN terminal stop := TRUE 
 FI.
END PROC println;

PROC outline (TEXT CONST t) :
 printline (t);
 putline (actual line).

 actual line :
  IF LENGTH (t) > 78
   THEN text (t, 78)
   ELSE t
  FI.
END PROC outline;

PROC printline (TEXT CONST t) :
 IF protocoll
  THEN putline (sysout, t)
 FI
END PROC print line;

PROC sys page :               (* Seitenvorschub auf Bildschirm und Datei *)
 IF vdt on AND NOT is scroll AND is not first
  THEN page
  ELSE is not first := TRUE
 FI;
 IF protocoll
  THEN putline (sysout, "#page#")
 FI;
 IF asterisk buffer <> ""
  THEN page no INCR 1;
       println ("PAGE " + text (page no, 3) + "  : " + asterisk buffer);
 FI;
 line no := 0
END PROC sys page;
 
BOOL PROC pagefeed necessary :
 line no = 0                  (* Liefert TRUE, wenn Seitenende erreicht *)
END PROC pagefeed necessary;  (* ist *)
 
PROC plot output (TEXT CONST t) :
 println (t);                 (* Ausgabeprozedur fuer das Plot - Programm *)
 print := FALSE
END PROC plot output;
 
BOOL PROC b stop request :      (* Liefert TRUE, wenn 'End'-Kommando im VDT *)
 terminal stop                  (* - Modus gegeben wird *)
END PROC b stop request;
 
BOOL PROC was print :         (* Liefert TRUE, falls Druckerprogramm *)
 print.                       (* vorher eine Zeile gedruckt hat *)
END PROC was print;
 
PROC vdt :
 IF vdt on AND is not first   (* VDT = Video Data Termination *)
  THEN do vdt                 (* Verhindert Scrolling des Bildschirms *)
 FI.
 
 do vdt :
  TEXT VAR t;
  out ("TIPPEN SIE : '+'; 'o'; 'e' : ");
  inchar (t);
  out (t);
  IF t = "+"                  (* '+' = Seitenvorschub *)
   THEN
   ELIF t = "o"               (* 'o' = Off; VDT wird abgeschaltet *)
    THEN vdt on := FALSE
   ELIF t = "e"               (* 'e' = End; Programm wird abgebrochen *)
    THEN terminal stop := TRUE
   ELSE out (""13""); vdt
  FI;
  line.
END PROC vdt;
 
PROC asterisk (TEXT CONST t) :
 asterisk buffer := t
END PROC asterisk;

PROC out(TEXT CONST a,b,c) :
 out(a);
 out(b);
 out(c)
END PROC out;


END PACKET rts;