summaryrefslogtreecommitdiff
path: root/lang/dynamo/1.8.7/src/dyn.rts
blob: c46684aafff3615fa2ce13562208a2cc78c2097a (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
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;