tecal/TeCal

Raw file
Back to index

  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
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
(**********************************************************************)
(*                                                                    *)
(*                      TeCal - Text Calculator                       *)
(*                                                                    *)
(*  Autor    : Andreas Schmeink                        06.09.1984     *)
(*  Korrektur: Hilmar v.d. Bussche                     17.09.1984     *)
(*                                                     20.09.1984     *)
(*  Adaption : Uwe Behrend, Andreas Schmeink           03.08.1987     *)
(**********************************************************************)
 
PACKET pick DEFINES pick up number, left range, right range,
                    replace number, last pick up ok :
 
(********************************************************************)
(*                                                                  *)
(*  Zahlen erkennen und schreiben für TeCal              12.09.84   *)
(*                                                                  *)
(********************************************************************)
 
LET ziffern = "0123456789", pseudoblankcode = 223;
 
ROW 10 REAL VAR ziffer plus eins
            := ROW 10 REAL : (0.0,1.0,2.0,3.0,4.0,5.0,6.0,7.0,8.0,9.0);
REAL VAR number;
BOOL VAR ziffer gefunden;
INT VAR anfang, ende, zeichencode, vorkommastellen, p, dezimalzeichen;
TEXT VAR worktext;
 
BOOL PROC last pick up ok:
   ziffer gefunden
END PROC last pick up ok;
 
REAL PROC code to digit (INT CONST code) :
   ziffer plus eins (code-47)
END PROC code to digit; 
 
INT PROC left range :
   anfang
END PROC left range;
 
INT PROC right range :
   ende
END PROC right range;
 
REAL PROC pick up number (TEXT CONST source, INT CONST where) :
 
   suche ende der zahl; 
   lies zahl ein;
   number.
 
suche ende der zahl :
   fange bei gegebener position an;
   IF vorzeichen THEN
      nach rechts ruecken
   FI; 
   WHILE erlaubtes zeichen REP 
      nach rechts ruecken 
   PER;
   ende merken.
 
fange bei gegebener position an:
   ziffer gefunden := FALSE;
   p := where;
   betrachte aktuelles zeichen.
 
nach rechts ruecken:
   p INCR 1;
   betrachte aktuelles zeichen.
 
nach links ruecken:
   p DECR 1;
   betrachte aktuelles zeichen.
 
ende merken :
   ende := p - 1.
 
lies zahl ein :
   fange hinter der zahl an;
   sammle ziffern auf;
   pruefe vorzeichen;
   werte exponent aus.
 
sammle ziffern auf :
   REP
      nach links ruecken;
      IF ziffer THEN
         ziffer behandeln
      ELIF punkt OR komma THEN
         IF wirkt als dezimalzeichen THEN
             dezimalzeichen behandeln
         ELSE ignorieren
         FI
      ELIF pseudoblank vor ziffer THEN
         ignorieren
      ELSE
         LEAVE sammle ziffern auf
      FI;
   PER.
 
pruefe vorzeichen :
   IF minus THEN
      anfang := p;
      number := number * -1.0
   ELIF plus THEN
      anfang := p
   ELSE
      anfang := p+1
   FI.
 
werte exponent aus :
   set exp (vorkommastellen+decimal exponent(number), number).
 
fange hinter der zahl an :
   vorkommastellen := 0;
   dezimalzeichen := 0;
   number := 0.0;
   p := ende + 1.
 
betrachte aktuelles zeichen: 
   zeichencode := code (source SUB p).
 
ziffer behandeln :
   ziffer gefunden := TRUE;
   number := (number + code to digit (zeichencode))/10.0;
   vorkommastellen INCR 1.
 
dezimalzeichen behandeln :
   dezimalzeichen := zeichencode;
   vorkommastellen := 0.
 
wirkt als dezimalzeichen :
   dezimalzeichen = 0 OR dezimalzeichen = zeichencode.
 
erlaubtes zeichen :
   ziffer OR punkt OR komma OR pseudoblank vor ziffer.
 
pseudoblank vor ziffer :
   zeichencode = pseudoblankcode AND pos (ziffern, source SUB (p+1) ) > 0.
 
vorzeichen : plus OR minus.
 
ziffer : zeichencode >= 48 AND zeichencode <= 57. 
 
plus : zeichencode = 43.
 
minus : zeichencode = 45.
 
punkt : zeichencode = 46.
 
komma : zeichencode = 44.
 
ignorieren :.
 
END PROC pick up number;
 
PROC replace number (TEXT VAR source, REAL CONST value, INT CONST where,
                                                        nachkommastellen) :
 
   alte grenzen feststellen;
   wenn noetig auf format der neuen zahl erweitern;
   zahl in text umwandeln;
   zahl ersetzen. 
 
alte grenzen feststellen :
   REAL VAR dummy; 
   dummy := pick up number (source, where).
 
wenn noetig auf format der neuen zahl erweitern :
   INT VAR schreibanfang := min (anfang, neuer anfang),
           schreibende := max (ende, neues ende).
 
neuer anfang : where - vorkommazeichen + 1.
 
vorkommazeichen : max (2,(decimal exponent (value) + 2)).
 
neues ende : where + nachkommastellen + 1.
 
zahl in text umwandeln :
  worktext := text (value,stellen,nachkommastellen);
  IF decimal exponent (value) < 0 THEN
     change (worktext," .","0."); change (worktext," -.","-0.");
  FI;
  IF nachkommastellen = 0 THEN 
     replace (worktext, LENGTH worktext, " ")
  FI;
  WHILE LENGTH worktext < schreibende-schreibanfang+1 REP
     worktext CAT " "
  PER.
 
zahl ersetzen : 
  WHILE LENGTH source < schreibende REP
     source CAT " "
  PER;
  replace (source, schreibanfang, worktext) .
 
stellen : where-schreibanfang+2+nachkommastellen. 
 
END PROC replace number;
 
END PACKET pick;
 
PACKET rechner DEFINES clear, push, result, do,
                       superklammer auf, superklammer zu,
                       empty, operand expected, dump:
 
(********************************************************************)
(*                                                                  *)
(*  Rechenwerk fuer TeCal                                13.09.84   *)
(*                                                                  *)
(********************************************************************)
 
LET  plus = 1, minus = 2, mal = 3, durch = 4, hoch = 5,
     monad minus = 6, klammer auf = 7, klammer zu = 8, gleich = 9; 
 
LET klammerpriostufe = 10, superklammerpriostufe = 500;
 
LET tiefe = 30; 
 
REAL VAR dummy;
BOOL VAR war operand; 
 
INT VAR operandentop, operatorentop, klammerprio, superklammerprio; 
 
ROW tiefe INT VAR operatorenstack;
ROW tiefe REAL VAR operandenstack; 
 
PROC superklammer auf :
   IF war operand THEN
      pop (dummy)
   FI;
   superklammerprio INCR superklammerpriostufe;
   klammerprio INCR superklammerpriostufe
END PROC superklammer auf;
 
PROC superklammer zu :
   IF superklammerprio > 0 THEN
      push (gleich);
      superklammerprio DECR superklammerpriostufe;
      klammerprio DECR superklammerpriostufe
   FI;
END PROC superklammer zu;
 
INT PROC prio (INT CONST op):
   klammer prio + elementar prio.
 
elementar prio :
   SELECT op OF 
   CASE plus,minus : 2
   CASE mal,durch  : 3
   CASE hoch       : 4
   CASE monadminus : 6
   CASE klammerzu  : 0
   CASE gleich     : -klammerprio+superklammerprio
   OTHERWISE errorstop ("prio("+text(op)+")"); 0
   END SELECT
END PROC prio;
 
PROC clear :
   operandentop := 0;
   operatorentop := 0; 
   war operand := FALSE;
   klammerprio := 0;
   superklammerprio := 0;
END PROC clear;
 
PROC push (INT CONST op) :
   enable stop;
   IF war operand THEN
      dyadischer operator oder gleich oder klammer zu 
   ELIF op = minus COR op = monad minus THEN
      push monadisches minus
   ELIF op = plus THEN
      (* ignoriere monad plus *)
   ELIF op = klammer auf THEN
      IF stack zu voll THEN
         errorstop ("Zuviele offene Klammern")
      FI;
      klammerprio INCR klammerpriostufe
   ELSE
      errorstop ("Zahl erwartet, letzten Operator ignoriert")
   FI.
 
dyadischer operator oder gleich oder klammer zu :
   IF op = monad minus COR op = klammer auf THEN
      (* errorstop ("Operator (+,-,*,/) vor Klammer auf fehlt")*)
      ignore last operand;
      push (op);
      LEAVE push
   ELSE
      WHILE prio (op) <= stack top prio REPEAT
         auswerten
      PER;
      push operator
   FI.
 
stack top prio : 
   IF operatorentop = 0 THEN -1
   ELSE operator DIV 10
   FI.
 
stack zu voll :
   operandentop >= tiefe - 4.
 
auswerten :
   REAL VAR op2;
   SELECT operator MOD 10 OF
   CASE monad minus : operand := - operand
   CASE plus : pop (op2); operand INCR op2
   CASE minus: pop (op2); operand DECR op2
   CASE mal  : pop (op2); operand := operand * op2
   CASE durch: pop (op2); operand := operand / op2 
   CASE hoch : pop (op2); operand := operand ** op2 
   OTHERWISE
(**) errorstop ("Im Opstack ("+text(operatorentop)+") gefunden : "+text(operator))
   END SELECT;
   war operand := TRUE;
   operatorentop DECR 1.
 
push operator :
   IF op = klammerzu THEN
      IF klammerprio > superklammerprio THEN
         klammerprio DECR klammerpriostufe (* ELSE ignoriere ")" zuviel *)
      FI
   ELIF op = gleich THEN
      klammerprio := superklammerprio; 
   ELSE
      operatorentop INCR 1;
      operator := prio (op) * 10 + op;
      war operand := FALSE
   FI.
 
push monadisches minus :
   operatorentop INCR 1;
   operator := prio (monad minus) * 10 + monad minus.
 
ignore last operand :
   pop (dummy).
 
END PROC push;
 
PROC push (REAL CONST op) :
   IF war operand THEN
      operand := op; (* Operand wird ueberschrieben *)
   ELSE
      operandentop INCR 1;
      operand := op;
      war operand := TRUE
   FI
END PROC push;
 
PROC pop (REAL VAR r) :
   IF operandentop = 0 THEN
      errorstop ("Operand fehlt")
   ELSE r := operand;
      operandentop DECR 1
   FI;
   war operand := FALSE
END PROC pop;
 
REAL PROC result :
   IF operanden top > 0 THEN operand ELSE 0.0 FI
END PROC result;
 
BOOL PROC empty :
   operandentop < 1
END PROC empty;
 
BOOL PROC operand expected :
   NOT war operand
END PROC operand expected;
 
PROC do (REAL PROC (REAL CONST) f):
   IF NOT war operand THEN
      push (f(result))
   ELSE
      operand := f(operand)
   FI
END PROC do;
 
PROC dump :
  INT VAR x,y;
  get cursor (x,y);
  cursor (1,1);
   INT VAR i;
   put(operatorentop);put ("OPERATOREN");
   FOR i FROM 1 UPTO operatorentop REP
       put (text (operatorenstack(i),8));
   PER;out (""5""); line; 
   put (operandentop);put ("OPERANDEN ");
   FOR i FROM 1 UPTO operandentop REP
       put (text (operandenstack(i),8,2));
   PER;out (""5""); line;
   put ("Klammern:");put(klammerprio);
   put ("Superklammern:");put(superklammerprio);
   IF war operand THEN put ("war operand") ELSE put ("war operator") FI;line;
   cursor (x,y);
END PROC dump;
 
.
operand : operandenstack (operandentop).
operator: operatorenstack(operatorentop).
 
END PACKET rechner;
 
PACKET tecalfunctions DEFINES merke, prozentsatz, kommastellen,
                              prozent, evaluate, tecal :
 
(********************************************************************)
(*                                                                  *)
(*  TeCal - Funktionen                                   15.09.84   *)
(*                                                                  *)
(********************************************************************)
 
LET operatorenliste = "+-*/^ ()=", gib ausdruck = ""15" gib wert : ";
 
REAL VAR speicher := 0.0, percent := 14.0, displayed value := -1.0;
INT VAR nachkommastellen := 2;
 
INT VAR zeiger,dachpos;   (* fuer evaluate *)
TEXT VAR char;            (* fuer evaluate *)
 
TEXT VAR status line, anzeigetext;
INT VAR anzeigestart, anzeigelaenge, memorystart, prozentstart;
init status line;
 
PROC evaluate (TEXT CONST formel):
   evaluate (formel,1)
END PROC evaluate;
 
PROC evaluate (TEXT CONST formel, INT CONST ab wo):
   enable stop;
   zum formelanfang; 
   REP
      zum naechsten relevanten zeichen;
      IF formelende THEN LEAVE evaluate
      FI;
      symbol verarbeiten
   UNTIL gleich zeichen verarbeitet PER.
 
zum formelanfang :
   dachpos := pos (formel,"^");
   zeiger:= ab wo - 1.
 
zum naechsten relevanten zeichen :
   REP
      zum naechsten wahrscheinlich relevanten zeichen
   UNTIL formelende COR wirklich relevant PER.
 
zum naechsten wahrscheinlich relevanten zeichen:
   zeiger := pos (formel,"%","=",zeiger+1);
   IF dachpos <> 0 CAND zeiger > dachpos THEN
      zeiger := dachpos;
      dachpos := pos (formel,"^",dachpos+1)
   FI.
 
formelende :
   zeiger = 0.
 
wirklich relevant :
   char := formel SUB zeiger;
   pos ("',.:;<", char) = 0.
 
symbol verarbeiten :
   IF ziffer THEN
      push (abs(pick up number(formel,zeiger)));
      zeiger := right range
   ELSE
      INT VAR op := pos (operatorenliste,char);
      IF op > 0 THEN
         push (op)
      ELIF char = "%" THEN
         do (REAL PROC (REAL CONST) prozent)
      ELSE errorstop ("TeCal FEHLER : symbol verarbeiten")
      FI
   FI.
 
gleichzeichen verarbeitet : char = "=".
 
ziffer : pos ("0123456789",char) > 0.
 
END PROC evaluate;
 
PROC merke (REAL CONST wert) :
 speicher := wert;
 set anzeigetext (speicher);
 replace (statusline,memorystart,anzeigetext);
 show status line
END PROC merke;
 
PROC merke (INT CONST wert) :
 merke (real (wert));
END PROC merke;
 
PROC prozentsatz (REAL CONST wert) :
 percent := wert;
 replace (statusline,prozentstart,text(percent,6,2));
 show status line;
END PROC prozentsatz;
 
PROC prozentsatz (INT CONST wert) :
 prozentsatz (real (wert));
END PROC prozentsatz;
 
PROC kommastellen (INT CONST anz stellen) :
 nachkommastellen := max  (  0,  min (anz stellen, 16)) ;
 set anzeigetext (0.0);
 replace (statusline,anzeigestart,anzeigetext);
 merke (speicher);
END PROC kommastellen;
 
REAL PROC prozent (REAL CONST wovon) :
 percent * wovon / 100.0
END PROC prozent;
 
REAL PROC runden (REAL CONST was) :
  round (was,nachkommastellen)
END PROC runden;
 
PROC init status line :
   statusline := 
"$Anzeige: & __________._________  $    %%%.%%% Memory: ----------.--------- &"
;  change all (statusline,"$",""15"");
   change all (statusline,"&",""14"");
   anzeigestart := pos (statusline,"_");
   anzeigelaenge:= pos (statusline," ",anzeigestart)-anzeigestart; 
   memorystart  := pos (statusline,"-");
   prozentstart := pos (statusline,"%");
   set anzeigetext (0.0);
   replace (statusline,anzeigestart,anzeigetext);
   set anzeigetext (speicher);
   replace (statusline,memorystart,anzeigetext);
   replace (statusline,prozentstart,text(percent,6,2))
END PROC init status line;
 
PROC show status line :
   cursor (1,y screen size); out (statusline);
   displayed value := 0.0;
   display value
END PROC show status line;
 
PROC display value :
   IF displayed value <> result THEN
      cursor (anzeigestart,y screen size);
      set anzeigetext (result);
      out (anzeigetext)
   FI.
 
END PROC display value;
 
PROC get expression (TEXT VAR exp) :
  cursor (1,yscreen size);
  out (gib ausdruck);
  (x screen size - 4 - LENGTH gib ausdruck) TIMESOUT " ";
  out (""14""15""8" ");
  cursor (LENGTH gib ausdruck, y screen size);
  editget (exp);
END PROC get expression;
 
PROC set anzeigetext (REAL CONST r) :
  IF decimal exponent (r) + nachkommastellen + 3 <= anzeigelaenge THEN
     anzeigetext := text (r,anzeigelaenge,nachkommastellen);
     IF decimal exponent (r) < 0 THEN
        change (anzeigetext," .","0."); change (anzeigetext," -.","-0.");
     FI;
     IF nachkommastellen = 0 THEN 
        replace (anzeigetext, LENGTH anzeigetext, " ")
     FI;
  ELSE
     anzeigetext := text (r,anzeigelaenge)
  FI
END PROC set anzeigetext;
 
(***************  TeCal - Editor - Schnittstelle  *****************)
 
 
LET  tecal tasten    = "tq%()*+-/=CEFHKLMNRSVW^T"9"?",
     funktionenliste = "LSCEFHKMNRVWtq%"9"T?"        ,
     zahlzeichen     = "1234567890.,-+"              ,
     std tasten      = "tqevw19dpgn"9""              ;
 
LET kommando prozent  = 15,
    kommando clear    = 3,
    kommando einlesen = 4,
    kommando formel   = 5,
    kommando recall   = 7,
    kommando lesen    = 1,
    kommando store    = 8,
    kommando naechste = 9,
    kommando q        = 14,
    kommando runden   = 10,
    kommando schreiben= 2,
    kommando umschalt = 13,
    kommando ver sum  = 11,
    kommando fenster  = 12,
    kommando type     = 17,
    kommando help     = 18;
 
LET x screen size       = 79,
    y screen size       = 24;
 
FILE VAR tecal file;
 
TEXT VAR record, input buffer;
INT VAR record pos;
 
PROC dateizeile lesen :
  set busy indicator;
  read record (tecal file, record);
  record pos := col (tecal file)
END PROC dateizeile lesen; 
 
PROC zahl aufsammeln :
   dateizeile lesen;
   REAL VAR zahl := pick up number (record, record pos);
   IF last pick up ok THEN
      push (zahl)
   ELSE
      errorstop ("Keine Zahl gefunden")
   FI
END PROC zahl aufsammeln;
 
REAL PROC spaltensumme :
 
   anfangsposition merken;
   nach oben laufen und addieren;
   zum anfang zurueck;
   summe.
 
nach oben laufen und addieren :
   WHILE NOT oben angekommen REP
      hochgehen und satz lesen;
      record auswerten
   PER.
 
anfangsposition merken :
   INT VAR alte zeile := line no (tecal file);
   dateizeile lesen;
   REAL VAR summe := pick up number (record,record pos);
   BOOL VAR weiterlaufen := TRUE
   IF NOT last pick up ok THEN
       summe := 0.0
   FI.
 
zum anfang zurueck :
   to line (tecalfile, alte zeile).
 
hochgehen und satz lesen :
   up (tecal file);
   read record (tecal file, record).
 
oben angekommen : line no (tecalfile) = 1 COR NOT weiterlaufen.
 
record auswerten :
   IF blankzeile THEN
      weiterlaufen := TRUE 
   ELIF kein zahlzeichen THEN
      weiterlaufen := FALSE
   ELSE
      summe INCR pick up number (record,record pos);
      weiterlaufen := last pick up ok
   FI.
 
blankzeile : LENGTH record < record pos COR (record SUB record pos) = " ".
 
kein zahlzeichen : pos (zahlzeichen,record SUB recordpos) = 0. 
 
END PROC spaltensumme;
 
PROC tecal (TEXT CONST filename) :
  type (""27"t");
  edit (filename).
 
END PROC tecal;
 
PROC tecal :
 IF groesster editor > 0
    THEN tecal auf editfile
    ELSE tecal (lastparam)
 FI.
 
tecal auf editfile :
   FILE VAR f := editfile;
   quit;
   tecal (f) .
 
END PROC tecal;
 
PROC tecal (FILE VAR ed file) :
  enable stop     ;
  open editor (groesster editor + 1, ed file,  TRUE,
               1, 1, x screen size, y screen size - 1);
  show status line;
  edit (groesster editor, tecal tasten + std tasten,
        PROC (TEXT CONST) tecal interpreter) .
 
END PROC tecal;
 
PROC tecal interpreter (TEXT CONST symbol) :
 
  tecal file := editfile ;
  nichts neu ;
  INT VAR kommando := pos (operatorenliste,symbol);
  IF kommando > 0 THEN
     normale rechenoperation
  ELSE kommando := pos (funktionenliste,symbol);
     sonderfunktion
  FI.
 
normale rechenoperation :
  IF operand expected CAND keine klammer auf THEN
     zahl aufsammeln
  FI;
  push (kommando);
  display value.
 
keine klammer auf : symbol <> "(".
 
sonderfunktion :
  SELECT kommando OF
    CASE kommando prozent  : do prozent
    CASE kommando clear    : do clear
    CASE kommando einlesen : do get
    CASE kommando formel   : do formelrechnung
    CASE kommando ver sum  : do spaltensumme
    CASE kommando recall   : do speicher lesen
    CASE kommando lesen    : do zahl aufsammeln
    CASE kommando store    : do speicher schreiben
    CASE kommando naechste : do zur naechsten zahl
    CASE kommando q        : quit
    CASE kommando runden   : do runden
    CASE kommando schreiben: do schreiben
    CASE kommando umschalt : do tecal abschalten
    CASE kommando type     : do type displayed value
(*  CASE kommando hor sum  : calculate ver sum*)
    CASE kommando fenster  : do fenster als zweiten operanden
(*  CASE kommando tab      :  calculate tab sum *)
    CASE kommando help     : do ("tecal auskunft")
    OTHERWISE              : std kommando interpreter (symbol)
  END SELECT.
 
do prozent :
  IF operand expected THEN
     zahl aufsammeln
  FI;
  do (REAL PROC (REAL CONST) prozent);
  display value.
 
do clear :
  clear;
  ueberschrift neu;
  show status line.
 
do get : 
  input buffer := "";
  get expression (input buffer);
  IF input buffer > " " THEN
     disable stop;
     superklammer auf;
     evaluate (input buffer);
     superklammer zu;
     show status line;
     enable stop;
  ELSE
     show status line
  FI.
 
do zahl aufsammeln :
  zahl aufsammeln;
  display value.
 
do speicher schreiben :
  merke (result);
  show status line.
 
do type displayed value :
  set anzeigetext (result);
  push(compress(anzeigetext)).
 
do speicher lesen :
  push (speicher);
  display value.
 
do spaltensumme :
  push (spaltensumme);
  display value.
 
do formelrechnung :
  dateizeile lesen;
     disable stop;
     superklammer auf;
     evaluate (record);
     superklammer zu;
     enable stop;
  display value;
  IF enthaelt gleichzeichen CAND NOT empty THEN 
     ergebnis dahinter schreiben 
  ELSE
     col (LENGTH record + 1)
  FI.
 
enthaelt gleichzeichen :
  INT VAR gleichpos := pos (record,"=");
  gleichpos > 0.
 
ergebnis dahinter schreiben :
  record pos := gleichpos + 2 + decimal exponent (result);
  gleich pos := pos (record, ".", recordpos + 1) -1;
  IF gleichpos > 0 THEN
     record pos := gleichpos
  FI;
  ergebnis eintragen und dateizeile zurueckschreiben.
 
ergebnis eintragen und dateizeile zurueckschreiben :
  replace number (record, result, record pos, nachkommastellen);
  write record (tecal file, record);
  zeile neu;
  col (record pos).
 
do zur naechsten zahl :
  dateizeile lesen;
  record pos := pos (record,"0","9",record pos);
  IF record pos = 0 THEN
     record pos := LENGTH record + 1
  FI;
  col (record pos).
 
do schreiben :
  IF NOT empty THEN
     dateizeile lesen;
     ergebnis eintragen und dateizeile zurueckschreiben
  FI.
 
do runden :
  IF NOT empty AND NOT operand expected THEN
     do (REAL PROC (REAL CONST) runden)
  FI.
 
do fenster als zweiten operanden :
  IF empty THEN 
     push (0.0)
  ELSE
     push (result)
  FI.
 
do tecal abschalten :
  quit;
  edit (tecalfile).
 
END PROC tecal interpreter;
 
clear;
kommando auf taste legen ("t","tecal");
(*kommando auf taste legen ("?","tecalauskunft");*)
 
END PACKET tecal functions;