|
DataMuseum.dkPresents historical artifacts from the history of: RC4000/8000/9000 |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about RC4000/8000/9000 Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - download
Length: 118272 (0x1ce00)
Types: TextFile
Names: »mcllist «
└─⟦9ccaf6601⟧ Bits:30008165 Bånd med SW8000 kildetekst/release værktøjer
└─⟦39138f30b⟧
└─⟦this⟧ »mcllist «
*algol mcltxt connect.no list.yes
mcltxt d.870506.1153
1 begin
2 <**************************************************************>
3 <* MCL compiler source text for Terminal Access System *>
4 <* *>
5 <* Compiles MCL source text to cmcl format code *>
6 <* Produce all code in core before writing it to file *>
7 <* *>
8 <* Henning Godske 870506 *>
9 <* A/S Regnecentralen *>
10 <* *>
11 <* Compiler call: <result>=algol <source> connect.no *>
12 <**************************************************************>
13
13 <**************************************************************>
14 <* Revision history *>
15 <* *>
16 <* 87.05.06 MCL compiler release 1.0 *>
17 <**************************************************************>
18
18 <*--------------------------------------*>
19 <* Constans used global *>
20 <*--------------------------------------*>
21 integer max_var, <* Max. numbers of var's *>
22 max_string, <* Max. numbers of chars. in text *>
23 max_code, <* Max. code address *>
24 keywords; <* Number of keywords *>
25 array pn(1:2); <* Program name *>
26 integer i; <* work *>
27
27 <* Reserve 50 segments for algol to run in, *>
28 <* use rest for code array *>
29 max_code:=((system(2,i,pn)//512)-50)*512;
30 keywords:=40;
31 max_var:=25;
32 max_string:=80;
33 begin
34 <*---------------------------*>
35 <* Globale scanner variables *>
36 <*---------------------------*>
37 integer array newintable(0:255);
38 integer item;
39 integer last_item;
40 integer token_type,
41 line_number,
42 token_number_val,
43 token_string_length,
44 token_number;
45 boolean token_var_sub;
46 long array item_val(0:200);
47 integer array item_kind(0:200);
48 long array token_text(1:200);
49 long array symbol_text(1:keywords);
50 integer array symbol_val(1:keywords);
51 zone source_text(256,2,stderror);
52 <*----------------------------*>
53 <* Globale compiler variables *>
54 <*----------------------------*>
55 boolean list_source, <* list.yes *>
56 show_warning, <* warning.yes *>
57 show_test, <* test.yes *>
58 show_code, <* code.yes *>
59 use_note, <* note.yes *>
60 make_code, <* Produce code *>
61 make_cmcl, <* make result file *>
62 warnings;
63 integer array tail(1:10);
64 real array cmcl_file,source_file(1:2);
65 integer next_free, <* Next free address in code *>
66 while_start, <* Current while block start *>
67 att_start, <* Current att or inc block start *>
68 s_line, <* Source line number *>
69 ii; <* work *>
70 real rr; <* work *>
71 boolean in_attention,
72 in_include;
73 integer array field op;
74 boolean array code(0:max_code); <* Code array with index in hw *>
75 zone cmcl_code(256,2,stderror);
76 <*------------------------------------------------*>
77 <* Token constants used global. Set in init_scan *>
78 <*------------------------------------------------*>
79 integer t_end_file,
80 t_case,
81 t_otherwise,
82 t_endselect,
83 t_else,
84 t_endif,
85 t_point,
86 t_text,
87 t_endmenu,
88 t_endwhile,
89 t_endattention,
90 t_endinclude,
91 t_select,
92 t_while,
93 t_menu,
94 t_attention,
95 t_include,
96 t_at,
97 t_write,
98 t_nl,
99 t_erase,
100 t_read,
101 t_get,
102 t_let,
103 t_send,
104 t_if,
105 t_execute,
106 t_note,
107 t_direct,
108 t_loop,
109 t_exit,
110 t_output,
111 t_convert,
112 t_echo,
113 t_of,
114 t_do,
115 t_then,
116 t_equal,
117 t_not,
118 t_on,
119 t_off,
120 t_int_start,
121 t_int_end,
122 t_unknown,
123 t_number,
124 t_string,
125 t_errstring,
126 t_var,
127 t_and,
128 t_or;
129
129 procedure init_error(nr);
130 <*----------------------------------------------------------------*>
131 <* Write initial error and stop *>
132 <*----------------------------------------------------------------*>
133 integer nr;
134 begin
135 integer i;
136 i:=1;
137 write(out,<:***:>,string pn(increase(i)));
138 if nr<1 or nr>7 then
139 nr:=8; <* Max. init error number used + 1 *>
140 write(out,<: :>,case nr of
141 (<:No source file specified:>,
142 <:Parameter:>,
143 <:Source file not found:>,
144 <:Process too small:>,
145 <:Source file not a text file:>,
146 <:Can't create result file:>,
147 <:Can't use result file:>,
148 <:Undefined error:>),<:<10>:>);
149 make_code:=false;
150 goto stop;
151 end;
152
152 procedure init_compiler;
153 <*----------------------------------------------------------------*>
154 <* Read FP parameters and init. global variables *>
155 <*----------------------------------------------------------------*>
156 begin
157 real array ra(1:2);
158 integer sy,i,j;
159
159 trapmode:=1 shift 10;
160 errorbits:=0;
161 warnings:=false;
162 list_source:=use_note:=false;
163 show_warning:=make_cmcl:=true;
164 show_code:=show_test:=false;
165 zero_code; <* nulstil kode område *>
166 make_code:=true;
167 next_free:=while_start:=0;
168 in_attention:=in_include:=false;
169 if max_code<512 then
170 init_error(4);
171 if (system(4,1,ra) shift (-12))=6 then
172 begin
173 system(4,0,ra);
174 make_cmcl:=true;
175 for j:=1,2 do
176 cmcl_file(j):=ra(j);
177 i:=2;
178 end
179 else
180 begin
181 make_cmcl:=false;
182 i:=1;
183 end;
184 if system(4,i,ra)<>(4 shift 12 + 10) then
185 <* error in source specification *>
186 init_error(1);
187 for j:=1,2 do
188 source_file(j):=ra(j);
189 i:=i+1;
190 sy:=system(4,i,ra);
191 while sy<>0 do
192 begin
193 if ra(1) = real <:test:> then
194 begin
195 i:=i+1;
196 if system(4,i,ra)<>(8 shift 12 + 10) then
197 <* error in yes/no spec. *>
198 init_error(2);
199 if ra(1) = real <:yes:> then
200 show_test:=true
201 else
202 begin
203 if ra(1) = real <:no:> then
204 show_test:=false
205 else
206 init_error(2);
207 end;
208 end;
209 if ra(1) = real <:code:> then
210 begin
211 i:=i+1;
212 if system(4,i,ra)<>(8 shift 12 + 10) then
213 <* error in yes/no spec. *>
214 init_error(2);
215 if ra(1) = real <:yes:> then
216 show_code:=true
217 else
218 begin
219 if ra(1) = real <:no:> then
220 show_code:=false
221 else
222 init_error(2);
223 end;
224 end;
225 if ra(1) = real <:list:> then
226 begin
227 i:=i+1;
228 if system(4,i,ra)<>(8 shift 12 + 10) then
229 <* error in yes/no spec. *>
230 init_error(2);
231 if ra(1) = real <:yes:> then
232 list_source:=true
233 else
234 begin
235 if ra(1) = real <:no:> then
236 list_source:=false
237 else
238 init_error(2);
239 end;
240 end;
241 if ra(1) = real <:note:> then
242 begin
243 i:=i+1;
244 if system(4,i,ra)<>(8 shift 12 + 10) then
245 <* error in yes/no spec. *>
246 init_error(2);
247 if ra(1) = real <:yes:> then
248 use_note:=true
249 else
250 begin
251 if ra(1) = real <:no:> then
252 use_note:=false
253 else
254 init_error(2);
255 end;
256 end;
257 if ra(1) = real <:warni:> add 'n' then
258 begin
259 i:=i+1;
260 if system(4,i,ra)<>(8 shift 12 + 10) then
261 <* error in yes/no spec. *>
262 init_error(2);
263 if ra(1) = real <:yes:> then
264 show_warning:=true
265 else
266 begin
267 if ra(1) = real <:no:> then
268 show_warning:=false
269 else
270 init_error(2);
271 end;
272 end;
273 i:=i+1;
274 sy:=system(4,i,ra);
275 end;
276 end;
277
277 procedure init_scan;
278 <*----------------------------------------------------------------*>
279 <* Init. intable and keyword table used by scanner *>
280 <*----------------------------------------------------------------*>
281 begin
282 integer i;
283
283 item_val(0):=0;
284 item_kind(0):=0;
285
285 <* Init intable *>
286 <* Kind: *>
287 <* 1 : Illegal number *>
288 <* 2 : Number *>
289 <* 3 - *>
290 <* 4 - *>
291 <* 5 - *>
292 <* 6 : Keyword *>
293 <* 7 : Delimiter *>
294 <* 8 : End line (EM, NL, FF) *>
295 <* 9 : Text start char: < *>
296 <* 10 : Text stop char: > *>
297 <* 11 : Char. in text or comment (--) *>
298 <* 12 : & or ^ or _ in text *>
299 <* 13 : Alfa in text or comment *>
300 <* 14 : Interval start char: ( *>
301 <* 15 : Interval stop char: ) *>
302 <* 16 : Symbol ! *>
303 <* 17 : Synbol = *>
304 <* 18 : Illegal character *>
305 <* *>
306 for i:=1 step 1 until 256 do
307 newintable(i-1):=
308 (case i of <* Kind *>
309 ( 0, <* nul *>
310 18, <* soh *>
311 18, <* stx *>
312 18, <* etx *>
313 18, <* eot *>
314 18, <* enq *>
315 18, <* ack *>
316 18, <* bel *>
317 18, <* bs *>
318 18, <* ht *>
319 8, <* nl *>
320 18, <* vt *>
321 8, <* ff *>
322 0, <* cr *>
323 18, <* so *>
324 18, <* si *>
325 18, <* dle *>
326 18, <* dc1 *>
327 18, <* dc2 *>
328 18, <* dc3 *>
329 18, <* dc4 *>
330 18, <* nak *>
331 18, <* syn *>
332 18, <* etb *>
333 18, <* can *>
334 8, <* em *>
335 18, <* sub *>
336 18, <* esc *>
337 18, <* fs *>
338 18, <* gs *>
339 18, <* rs *>
340 18, <* us *>
341 7, <* *>
342 16, <* ! *>
343 18, <* " *>
344 18, <* # *>
345 18, <* $ *>
346 18, <* % *>
347 18, <* & *>
348 18, <* ' *>
349 14, <* ( *>
350 15, <* ) *>
351 18, <* * *>
352 18, <* + *>
353 18, <* , *>
354 1, <* - *>
355 18, <* . *>
356 18, <* / *>
357 2, <* 0 *>
358 2, <* 1 *>
359 2, <* 2 *>
360 2, <* 3 *>
361 2, <* 4 *>
362 2, <* 5 *>
363 2, <* 6 *>
364 2, <* 7 *>
365 2, <* 8 *>
366 2, <* 9 *>
367 18, <* : *>
368 18, <* ; *>
369 1, <* < *>
370 17, <* = *>
371 10, <* > *>
372 18, <* ? *>
373 18, <* @ *>
374 6, <* A *>
375 6, <* B *>
376 6, <* C *>
377 6, <* D *>
378 6, <* E *>
379 6, <* F *>
380 6, <* G *>
381 6, <* H *>
382 6, <* I *>
383 6, <* J *>
384 6, <* K *>
385 6, <* L *>
386 6, <* M *>
387 6, <* N *>
388 6, <* O *>
389 6, <* P *>
390 6, <* Q *>
391 6, <* R *>
392 6, <* S *>
393 6, <* T *>
394 6, <* U *>
395 6, <* V *>
396 6, <* W *>
397 6, <* X *>
398 6, <* Y *>
399 6, <* Z *>
400 6, <* Æ *>
401 6, <* Ø *>
402 6, <* Å *>
403 18, <* ^ *>
404 18, <* _ *>
405 18, <* ` *>
406 6, <* a *>
407 6, <* b *>
408 6, <* c *>
409 6, <* d *>
410 6, <* e *>
411 6, <* f *>
412 6, <* g *>
413 6, <* h *>
414 6, <* i *>
415 6, <* j *>
416 6, <* k *>
417 6, <* l *>
418 6, <* m *>
419 6, <* n *>
420 6, <* o *>
421 6, <* p *>
422 6, <* q *>
423 6, <* r *>
424 6, <* s *>
425 6, <* t *>
426 6, <* u *>
427 6, <* v *>
428 6, <* w *>
429 6, <* x *>
430 6, <* y *>
431 6, <* z *>
432 6, <* æ *>
433 6, <* ø *>
434 6, <* å *>
435 18, <* ü *>
436 18, <* del *>
437 <*-------------------*>
438 0, <* nul *>
439 0, <* soh *>
440 0, <* stx *>
441 0, <* etx *>
442 0, <* eot *>
443 0, <* enq *>
444 0, <* ack *>
445 0, <* bel *>
446 0, <* bs *>
447 0, <* ht *>
448 8, <* nl *>
449 0, <* vt *>
450 8, <* ff *>
451 0, <* cr *>
452 0, <* so *>
453 0, <* si *>
454 0, <* dle *>
455 0, <* dc1 *>
456 0, <* dc2 *>
457 0, <* dc3 *>
458 0, <* dc4 *>
459 0, <* nak *>
460 0, <* syn *>
461 0, <* etb *>
462 0, <* can *>
463 8, <* em *>
464 0, <* sub *>
465 0, <* esc *>
466 0, <* fs *>
467 0, <* gs *>
468 0, <* rs *>
469 0, <* us *>
470 11, <* *>
471 11, <* ! *>
472 11, <* " *>
473 11, <* # *>
474 11, <* $ *>
475 11, <* % *>
476 12, <* & *>
477 11, <* ' *>
478 11, <* ( *>
479 11, <* ) *>
480 11, <* * *>
481 11, <* + *>
482 11, <* , *>
483 11, <* - *>
484 11, <* . *>
485 11, <* / *>
486 11, <* 0 *>
487 11, <* 1 *>
488 11, <* 2 *>
489 11, <* 3 *>
490 11, <* 4 *>
491 11, <* 5 *>
492 11, <* 6 *>
493 11, <* 7 *>
494 11, <* 8 *>
495 11, <* 9 *>
496 11, <* : *>
497 11, <* ; *>
498 9, <* < *>
499 11, <* = *>
500 1, <* > *>
501 11, <* ? *>
502 11, <* @ *>
503 13, <* A *>
504 13, <* B *>
505 13, <* C *>
506 13, <* D *>
507 13, <* E *>
508 13, <* F *>
509 13, <* G *>
510 13, <* H *>
511 13, <* I *>
512 13, <* J *>
513 13, <* K *>
514 13, <* L *>
515 13, <* M *>
516 13, <* N *>
517 13, <* O *>
518 13, <* P *>
519 13, <* Q *>
520 13, <* R *>
521 13, <* S *>
522 13, <* T *>
523 13, <* U *>
524 13, <* V *>
525 13, <* W *>
526 13, <* X *>
527 13, <* Y *>
528 13, <* Z *>
529 13, <* Æ *>
530 13, <* Ø *>
531 13, <* Å *>
532 12, <* ^ *>
533 8, <* _ *>
534 11, <* ` *>
535 13, <* a *>
536 13, <* b *>
537 13, <* c *>
538 13, <* d *>
539 13, <* e *>
540 13, <* f *>
541 13, <* g *>
542 13, <* h *>
543 13, <* i *>
544 13, <* j *>
545 13, <* k *>
546 13, <* l *>
547 13, <* m *>
548 13, <* n *>
549 13, <* o *>
550 13, <* p *>
551 13, <* q *>
552 13, <* r *>
553 13, <* s *>
554 13, <* t *>
555 13, <* u *>
556 13, <* v *>
557 13, <* w *>
558 13, <* x *>
559 13, <* y *>
560 13, <* z *>
561 13, <* æ *>
562 13, <* ø *>
563 13, <* å *>
564 11, <* ü *>
565 0 ))<* del *>
566 shift 12 +
567 (case i of <* Value *>
568 ( 0, <* nul *>
569 0, <* soh *>
570 0, <* stx *>
571 0, <* etx *>
572 0, <* eot *>
573 0, <* enq *>
574 0, <* ack *>
575 0, <* bel *>
576 0, <* bs *>
577 0, <* ht *>
578 10, <* nl *>
579 0, <* vt *>
580 12, <* ff *>
581 0, <* cr *>
582 0, <* so *>
583 0, <* si *>
584 0, <* dle *>
585 0, <* dc1 *>
586 0, <* dc2 *>
587 0, <* dc3 *>
588 0, <* dc4 *>
589 0, <* nak *>
590 0, <* syn *>
591 0, <* etb *>
592 0, <* can *>
593 25, <* em *>
594 0, <* sub *>
595 0, <* esc *>
596 0, <* fs *>
597 0, <* gs *>
598 0, <* rs *>
599 0, <* us *>
600 32, <* *>
601 33, <* ! *>
602 34, <* " *>
603 35, <* # *>
604 36, <* $ *>
605 37, <* % *>
606 38, <* & *>
607 39, <* ' *>
608 40, <* ( *>
609 41, <* ) *>
610 42, <* * *>
611 43, <* + *>
612 44, <* , *>
613 128, <* - *>
614 46, <* . *>
615 47, <* / *>
616 48, <* 0 *>
617 49, <* 1 *>
618 50, <* 2 *>
619 51, <* 3 *>
620 52, <* 4 *>
621 53, <* 5 *>
622 54, <* 6 *>
623 55, <* 7 *>
624 56, <* 8 *>
625 57, <* 9 *>
626 58, <* : *>
627 59, <* ; *>
628 128, <* < *>
629 61, <* = *>
630 62, <* > *>
631 63, <* ? *>
632 64, <* @ *>
633 65, <* A *>
634 66, <* B *>
635 67, <* C *>
636 68, <* D *>
637 69, <* E *>
638 70, <* F *>
639 71, <* G *>
640 72, <* H *>
641 73, <* I *>
642 74, <* J *>
643 75, <* K *>
644 76, <* L *>
645 77, <* M *>
646 78, <* N *>
647 79, <* O *>
648 80, <* P *>
649 81, <* Q *>
650 82, <* R *>
651 83, <* S *>
652 84, <* T *>
653 85, <* U *>
654 86, <* V *>
655 87, <* W *>
656 88, <* X *>
657 89, <* Y *>
658 90, <* Z *>
659 91, <* Æ *>
660 92, <* Ø *>
661 93, <* Å *>
662 94, <* ^ *>
663 95, <* _ *>
664 96, <* ` *>
665 65, <* a *>
666 66, <* b *>
667 67, <* c *>
668 68, <* d *>
669 69, <* e *>
670 70, <* f *>
671 71, <* g *>
672 72, <* h *>
673 73, <* i *>
674 74, <* j *>
675 75, <* k *>
676 76, <* l *>
677 77, <* m *>
678 78, <* n *>
679 79, <* o *>
680 80, <* p *>
681 81, <* q *>
682 82, <* r *>
683 83, <* s *>
684 84, <* t *>
685 85, <* u *>
686 86, <* v *>
687 87, <* w *>
688 88, <* x *>
689 89, <* y *>
690 90, <* z *>
691 91, <* æ *>
692 92, <* ø *>
693 93, <* å *>
694 126, <* ü *>
695 0, <* del *>
696 <*-------------------*>
697 0, <* nul *>
698 0, <* soh *>
699 0, <* stx *>
700 0, <* etx *>
701 0, <* eot *>
702 0, <* enq *>
703 0, <* ack *>
704 0, <* bel *>
705 0, <* bs *>
706 0, <* ht *>
707 10, <* nl *>
708 0, <* vt *>
709 12, <* ff *>
710 0, <* cr *>
711 0, <* so *>
712 0, <* si *>
713 0, <* dle *>
714 0, <* dc1 *>
715 0, <* dc2 *>
716 0, <* dc3 *>
717 0, <* dc4 *>
718 0, <* nak *>
719 0, <* syn *>
720 0, <* etb *>
721 0, <* can *>
722 25, <* em *>
723 0, <* sub *>
724 0, <* esc *>
725 0, <* fs *>
726 0, <* gs *>
727 0, <* rs *>
728 0, <* us *>
729 32, <* *>
730 33, <* ! *>
731 34, <* " *>
732 35, <* # *>
733 36, <* $ *>
734 37, <* % *>
735 38, <* & *>
736 39, <* ' *>
737 40, <* ( *>
738 41, <* ) *>
739 42, <* * *>
740 43, <* + *>
741 44, <* , *>
742 45, <* - *>
743 46, <* . *>
744 47, <* / *>
745 48, <* 0 *>
746 49, <* 1 *>
747 50, <* 2 *>
748 51, <* 3 *>
749 52, <* 4 *>
750 53, <* 5 *>
751 54, <* 6 *>
752 55, <* 7 *>
753 56, <* 8 *>
754 57, <* 9 *>
755 58, <* : *>
756 59, <* ; *>
757 60, <* < *>
758 61, <* = *>
759 0, <* > *>
760 63, <* ? *>
761 64, <* @ *>
762 65, <* A *>
763 66, <* B *>
764 67, <* C *>
765 68, <* D *>
766 69, <* E *>
767 70, <* F *>
768 71, <* G *>
769 72, <* H *>
770 73, <* I *>
771 74, <* J *>
772 75, <* K *>
773 76, <* L *>
774 77, <* M *>
775 78, <* N *>
776 79, <* O *>
777 80, <* P *>
778 81, <* Q *>
779 82, <* R *>
780 83, <* S *>
781 84, <* T *>
782 85, <* U *>
783 86, <* V *>
784 87, <* W *>
785 88, <* X *>
786 89, <* Y *>
787 90, <* Z *>
788 91, <* Æ *>
789 92, <* Ø *>
790 93, <* Å *>
791 94, <* ^ *>
792 95, <* _ *>
793 96, <* ` *>
794 97, <* a *>
795 98, <* b *>
796 99, <* c *>
797 100, <* d *>
798 101, <* e *>
799 102, <* f *>
800 103, <* g *>
801 104, <* h *>
802 105, <* i *>
803 106, <* j *>
804 107, <* k *>
805 108, <* l *>
806 109, <* m *>
807 110, <* n *>
808 111, <* o *>
809 112, <* p *>
810 113, <* q *>
811 114, <* r *>
812 115, <* s *>
813 116, <* t *>
814 117, <* u *>
815 118, <* v *>
816 119, <* w *>
817 120, <* x *>
818 121, <* y *>
819 122, <* z *>
820 123, <* æ *>
821 124, <* ø *>
822 125, <* å *>
823 126, <* ü *>
824 0 ))<* del *>
825 extract 12;
826
826 intable(newintable);
827 t_end_file :=00;
828 t_case :=01;
829 t_otherwise :=02;
830 t_endselect :=03;
831 t_else :=04;
832 t_endif :=05;
833 t_point :=06;
834 t_text :=07;
835 t_endmenu :=08;
836 t_endwhile :=09;
837 t_endattention :=10;
838 t_endinclude :=11;
839 t_select :=12;
840 t_while :=13;
841 t_menu :=14;
842 t_attention :=15;
843 t_include :=16;
844 t_at :=17;
845 t_write :=18;
846 t_nl :=19;
847 t_erase :=20;
848 t_read :=21;
849 t_get :=22;
850 t_let :=23;
851 t_send :=24;
852 t_if :=25;
853 t_execute :=26;
854 t_note :=27;
855 t_direct :=28;
856 t_loop :=29;
857 t_exit :=30;
858 t_output :=31;
859 t_convert :=32;
860 t_echo :=33;
861 t_of :=34;
862 t_do :=35;
863 t_then :=36;
864 t_equal :=37;
865 t_not :=38;
866 t_on :=39;
867 t_off :=40;
868 t_int_start :=41;
869 t_int_end :=42;
870 t_unknown :=43;
871 t_number :=44;
872 t_string :=45;
873 t_errstring :=46;
874 t_var :=47;
875 t_and :=48;
876 t_or :=49;
877
877 <* Keywords for mcl *>
878 <* Bemærk alfabetisk opstilling *>
879 for i:=1 step 1 until keywords do
880 begin
881 symbol_text(i):=
882 case i of
883 ( long <:AND:>,
884 long <:AT:>,
885 long <:ATTEN:> add 'T',
886 long <:CASE:>,
887 long <:CONVE:> add 'R',
888 long <:DIREC:> add 'T',
889 long <:DO:>,
890 long <:ECHO:>,
891 long <:ELSE:>,
892 long <:ENDAT:> add 'T',
893 long <:ENDIF:>,
894 long <:ENDIN:> add 'C',
895 long <:ENDME:> add 'N',
896 long <:ENDSE:> add 'L',
897 long <:ENDWH:> add 'I',
898 long <:ERASE:>,
899 long <:EXECU:> add 'T',
900 long <:EXIT:>,
901 long <:GET:>,
902 long <:IF:>,
903 long <:INCLU:> add 'D',
904 long <:LET:>,
905 long <:LOOP:>,
906 long <:MENU:>,
907 long <:NL:>,
908 long <:NOTE:>,
909 long <:OF:>,
910 long <:OFF:>,
911 long <:ON:>,
912 long <:OR:>,
913 long <:OTHER:> add 'W',
914 long <:OUTPU:> add 'T',
915 long <:POINT:>,
916 long <:READ:>,
917 long <:SELEC:> add 'T',
918 long <:SEND:>,
919 long <:TEXT:>,
920 long <:THEN:>,
921 long <:WHILE:>,
922 long <:WRITE:> );
923
923 <* Token values for keywords *>
924 symbol_val(i):= case i of
925 (t_and, t_at, t_attention, t_case, t_convert, t_direct,
926 t_do, t_echo, t_else, t_endattention,
927 t_endif, t_endinclude, t_endmenu,
928 t_endselect, t_endwhile, t_erase,
929 t_execute, t_exit, t_get, t_if,
930 t_include, t_let, t_loop, t_menu,
931 t_nl, t_note, t_of, t_off, t_on, t_or,
932 t_otherwise, t_output, t_point,
933 t_read, t_select, t_send, t_text,
934 t_then, t_while, t_write);
935 end;
936 end;
937
937
937 procedure warning(nr);
938 <*----------------------------------------------------------------*>
939 <* Write warning on current output *>
940 <*----------------------------------------------------------------*>
941 value nr;
942 integer nr;
943 begin
944 if show_warning then
945 begin
946 if list_source then
947 write(out,<:<10>***warning :>)
948 else
949 write(out,<:<10>:>,<<dddd >,line_number,<:: warning :>);
950 if nr<1 or nr>4 then
951 nr:=5; <* Max. warning number used + 1 *>
952 write(out,<< dd>,token_number,<:. :>,case nr of
953 (<:no link:>,
954 <:too many menu lines:>,
955 <:illegal character:>,
956 <:constant string with interval:>,
957 <:undefined warning:>));
958 end;
959 warnings:=true;
960 end;
961
961 procedure mcl_error(nr);
962 <*----------------------------------------------------------------*>
963 <* Write error on current output *>
964 <*----------------------------------------------------------------*>
965 value nr;
966 integer nr;
967 begin
968 if list_source then
969 write(out,<:<10>***error :>)
970 else
971 write(out,<:<10>:>,<<dddd >,line_number,<:: error :>);
972 if nr<1 or nr>12 then
973 nr:=12; <* Max. error number used + 1 *>
974 write(out,<< dd>,token_number,<:. :>,case nr of
975 (<:no selectable menu text lines:>,
976 <:string size:>,
977 <:non constant string:>,
978 <:empty string:>,
979 <:illegal number:>,
980 <:column > 79:>,
981 <:line > 24:>,
982 <:line = 0:>,
983 <:already in attention or include:>,
984 <:point not unique:>,
985 <:source line too long:>,
986 <:undefined error:>));
987 make_code:=false;
988 end;
989
989 procedure comp_error(nr);
990 <*----------------------------------------------------------------*>
991 <* Called when error in this program is detected *>
992 <* Write error and goto stop *>
993 <*----------------------------------------------------------------*>
994 integer nr;
995 begin
996 ii:=1;
997 write(out,<:<10>***internal :>,nr,<:<10>:>);
998 goto stop;
999 end;
1000
1000
1000 procedure syntax_error(nr);
1001 <*----------------------------------------------------------------*>
1002 <* writes syntax error on current output *>
1003 <* signals that no usefull code is produced *>
1004 <*----------------------------------------------------------------*>
1005 value nr;
1006 integer nr;
1007 begin
1008 if list_source then
1009 write(out,<< dddd>,<:<10>***syntax :>)
1010 else
1011 write(out,<:<10>:>,<<dddd >,line_number,<:: syntax :>);
1012 if nr<1 or nr>23 then
1013 nr:=24; <* Max. error number used + 1 *>
1014 write(out,<< dd>,token_number,<:. :>,case nr of
1015 (<:error in string:>,
1016 <:unknown keyword:>,
1017 <:number missing:>,
1018 <:interval error:>,
1019 <:) missing:>,
1020 <:variabel missing:>,
1021 <:OF missing:>,
1022 <:CASE expected:>,
1023 <:ENDSELECT expected:>,
1024 <:= missing:>,
1025 <:DO missing:>,
1026 <:ENDWHILE expected:>,
1027 <:POINT expected:>,
1028 <:too many points:>,
1029 <:ENDMENU expected:>,
1030 <:ENDATTENTION expected:>,
1031 <:ENDINCLUDE expected:>,
1032 <:sentence expected:>,
1033 <:THEN missing:>,
1034 <:ENDIF expected:>,
1035 <:ON or OFF missing:>,
1036 <:structure:>,
1037 <:illegal variable:>,
1038 <:undefined error:>));
1039 make_code:=false;
1040 end;
1041
1041 procedure syntax_scan(nr);
1042 <*----------------------------------------------------------------*>
1043 <* write syntax error and scans to next sentence *>
1044 <*----------------------------------------------------------------*>
1045 value nr;
1046 integer nr;
1047 begin
1048 syntax_error(nr);
1049 while token_type>t_echo do
1050 begin
1051 next_token;
1052 if token_type=t_errstring then
1053 syntax_error(1);
1054 if token_type=t_unknown then
1055 syntax_error(2);
1056 end;
1057 end;
1058
1058 procedure write_headline;
1059 <*----------------------------------------------------------------*>
1060 <* Write form-feed and headline on current output *>
1061 <*----------------------------------------------------------------*>
1062 begin
1063 integer i;
1064 real array on(1:2);
1065
1065 system(6,i,on);
1066 i:=1;
1067 write(out,<:<12><10>:>,string on(increase(i)),<: :>);
1068 i:=1;
1069 write(out,<:mcl d.:>,<<zddddd>,systime(5,0,rr),<:.:>,rr);
1070 i:=1;
1071 write(out,<: source file: :>,string source_file(increase(i)),<:<10>:>);
1072 end;
1073
1073
1073 procedure get_new_line;
1074 <*----------------------------------------------------------------*>
1075 <* Read next line from source and list this line *>
1076 <* on current output if LIST.YES *>
1077 <*----------------------------------------------------------------*>
1078 begin
1079 integer ch;
1080 tableindex:=0;
1081 last_item:=read_all(source_text,item_val,item_kind,1);
1082 while item_val(last_item)=95 do
1083 begin
1084 item_kind(last_item):=12;
1085 if table_index=128 then
1086 begin
1087 last_item:=last_item+1;
1088 read_char(source_text,ch);
1089 item_kind(last_item):=13;
1090 item_val(last_item):=ch;
1091 table_index:=128;
1092 end;
1093 last_item:=read_all(source_text,item_val,item_kind,last_item+1)+last_item;
1094 end;
1095 item:=0;
1096 token_number:=0;
1097 if -,(item_kind(1)=8 and item_val(1)=25) then
1098 begin
1099 line_number:=line_number+1;
1100 if list_source then
1101 begin
1102 <* Write line *>
1103 long array field key_word;
1104 integer i;
1105 write(out,<:<10>:>,<<dddd>,line_number,<: : :>);
1106 for i:=1 step 1 until abs last_item do
1107 if (item_kind(i)>8) or (item_kind(i)=7) then
1108 begin
1109 if (item_kind(i)=12) and
1110 (item_val(i)<>95) and
1111 (item_val(i-1)<>95) and
1112 (item_kind(i+1)=13) and
1113 (item_val(i+1)>96) then
1114 item_val(i+1):=item_val(i+1)-32;
1115 outchar(out,item_val(i) extract 24);
1116 end
1117 else
1118 if item_kind(i)=6 then
1119 begin
1120 key_word:=(i-1)*4;
1121 write(out,item_val.key_word);
1122 while item_kind(i+1)=6 do
1123 i:=i+1;
1124 end
1125 else
1126 if item_kind(i)<3 then
1127 write(out,<<d>,item_val(i))
1128 else
1129 if (item_kind(i)=8) and item_val(i)=12 then
1130 write_headline;
1131 end;
1132 if last_item<0 then
1133 begin
1134 while readchar(source_text,ch)<>8 do;
1135 last_item:=-last_item;
1136 end;
1137 end;
1138 end;
1139
1139 procedure next_item;
1140 <*----------------------------------------------------------------*>
1141 <* Get next item from line read from source *>
1142 <*----------------------------------------------------------------*>
1143 begin
1144 if item=0 then
1145 item:=1
1146 else
1147 if item_kind(item)=8 then
1148 begin
1149 if item_val(item)<>25 then
1150 begin
1151 get_new_line;
1152 item:=1;
1153 end;
1154 end
1155 else
1156 if item=last_item then
1157 begin
1158 item_kind(item):=8;
1159 item_val(item):=10;
1160 mcl_error(11);
1161 end
1162 else
1163 item:=item+1;
1164 end;
1165
1165 procedure next_token;
1166 <*----------------------------------------------------------------*>
1167 <* Get next token value evaluated from *>
1168 <* reading one or more items *>
1169 <*----------------------------------------------------------------*>
1170 begin
1171 integer index,low_index,high_index,
1172 i,text_ch,ch;
1173 next_token_start:
1174 next_item;
1175 case item_kind(item) of
1176 begin
1177 <* 1 Illegal number *>
1178 comp_error(1);
1179 <* 2 Number *>
1180 begin
1181 token_number_val:=item_val(item);
1182 token_type:=t_number;
1183 end;
1184 <* 3 *>
1185 comp_error(2);
1186 <* 4 *>
1187 comp_error(3);
1188 <* 5 *>
1189 comp_error(4);
1190 <* 6 keyword *>
1191 begin
1192 if (item_val(item) shift 8)=0 then
1193 begin <* 1 char. then VARIABLE *>
1194 token_type:=t_var;
1195 token_number_val:=(item_val(item) shift (-40))-65;
1196 if token_number_val>31 then
1197 token_number_val:=token_number_val-32;
1198 if token_number_val>max_var then
1199 syntax_error(23);
1200 end
1201 else
1202 begin <* Keyword *>
1203 index:=keywords//2;
1204 low_index:=1;
1205 high_index:=keywords;
1206 <* Use binary search to find value *>
1207 while item_val(item)<>symbol_text(index) do
1208 begin
1209 if low_index>=high_index then
1210 begin
1211 <* error keyword not found *>
1212 token_type:=t_unknown;
1213 goto key_word_end;
1214 end;
1215 if item_val(item) < symbol_text(index) then
1216 high_index:=index-1
1217 else
1218 low_index:=index+1;
1219 index:=(high_index-low_index)//2+low_index;
1220 if index<1 or index>keywords then
1221 comp_error(5);
1222 end;
1223 token_type:=symbol_val(index);
1224 key_word_end:
1225 while item_kind(item+1)=6 do
1226 next_item;
1227 end;
1228 end;
1229 <* 7 Delimiter *>
1230 goto next_token_start;
1231 <* 8 End line *>
1232 if item_val(item)=25 then
1233 token_type:=t_end_file
1234 else
1235 goto next_token_start;
1236 <* 9 Text start < *>
1237 begin
1238 boolean string_error;
1239 string_error:=false;
1240 <* init token text *>
1241 for i:=1 step 1 until 15 do
1242 token_text(i):=0;
1243 token_var_sub:=false;
1244 next_item;
1245 text_ch:=1;
1246 if (item_kind(item)<9) or (item_kind(item)>13) then
1247 begin
1248 string_error:=true;
1249 goto string_end;
1250 end;
1251 while (item_kind(item)<>10) do
1252 begin
1253 if (item_kind(item)<9) or (item_kind(item)>13) then
1254 begin
1255 string_error:=true;
1256 goto string_end;
1257 end;
1258 if item_kind(item)=12 then
1259 begin
1260 if item_val(item)=94 then
1261 begin
1262 next_item;
1263 ch:=item_val(item) extract 5;
1264 if (item_kind(item)<11) or
1265 (item_kind(item)>13) or
1266 (ch=0) then
1267 begin
1268 string_error:=true;
1269 goto string_end;
1270 end;
1271 end
1272 else
1273 if item_val(item)=95 then
1274 begin
1275 next_item;
1276 ch:=item_val(item);
1277 if item_kind(item)=8 then
1278 begin
1279 string_error:=true;
1280 goto string_end;
1281 end;
1282 if item_kind(item)=10 then
1283 table_index:=128;
1284 end
1285 else
1286 begin
1287 next_item;
1288 if item_kind(item)<>13 then
1289 begin
1290 string_error:=true;
1291 ch:=0;
1292 end
1293 else
1294 begin
1295 ch:=item_val(item)+63;
1296 if ch>159 then
1297 ch:=ch-32;
1298 token_var_sub:=true;
1299 if ch-128>max_var then
1300 syntax_error(23);
1301 end;
1302 end;
1303 end
1304 else
1305 ch:=item_val(item);
1306 token_text((text_ch-1)//6+1):=
1307 token_text((text_ch-1)//6+1) shift 8 + ch extract 8;
1308 if text_ch<82 then
1309 text_ch:=text_ch+1;
1310 next_item;
1311 end; <* Insert in string *>
1312 string_end:
1313 token_string_length:=text_ch-1;
1314 i:=token_string_length mod 6;
1315 if i<>0 then
1316 token_text((token_string_length)//6+1):=
1317 token_text((token_string_length)//6+1) shift ((6-i)*8);
1318 if string_error then
1319 token_type:=t_errstring
1320 else
1321 token_type:=t_string;
1322 end;
1323 <* 10 Illegal char. > *>
1324 begin
1325 warning(3);
1326 goto next_token_start;
1327 end;
1328 <* 11 Comment -- *>
1329 begin
1330 next_item;
1331 if item_kind(item)<>11 then
1332 warning(3);
1333 next_item;
1334 while (item_kind(item)<>8) do
1335 next_item;
1336 if item_val(item)=25 then
1337 begin
1338 token_type:=t_end_file;
1339 goto next_token_end;
1340 end;
1341 goto next_token_start;
1342 end;
1343 <* 12 & in text *>
1344 comp_error(7);
1345 <* 13 Alfa in text *>
1346 comp_error(8);
1347 <* 14 Int start ( *>
1348 token_type:=t_int_start;
1349 <* 15 Int stop ) *>
1350 token_type:=t_int_end;
1351 <* 16 != *>
1352 begin
1353 next_item;
1354 if item_kind(item)<>17 then
1355 syntax_error(10);
1356 token_type:=t_not;
1357 end;
1358 <* 17 = *>
1359 token_type:=t_equal;
1360 <* 18 Illegal char. *>
1361 begin
1362 warning(3);
1363 goto next_token_start;
1364 end;
1365 end;
1366 next_token_end:
1367 token_number:=token_number+1;
1368 end; <* Next token *>
1369
1369 procedure zero_code;
1370 <*----------------------------------------------------------------*>
1371 <* insert zero's in hole code area *>
1372 <*----------------------------------------------------------------*>
1373 begin
1374 long array field laf;
1375 integer i;
1376
1376 laf:=0;
1377 code(0):=false;
1378 for i:=1 step 1 until max_code//4 do
1379 code.laf(i):=0;
1380 end;
1381
1381
1381 integer procedure set_op(opcode_nr,code_length);
1382 <*----------------------------------------------------------------*>
1383 <* Set OP to current opcode start, *>
1384 <* insert opcode nr and s_line, code_length is number *>
1385 <* of half word that shall be free in the same segment. *>
1386 <* If it's not posible in current segment start in *>
1387 <* next segment *>
1388 <*----------------------------------------------------------------*>
1389 value opcode_nr,code_length;
1390 integer opcode_nr,code_length;
1391 begin
1392 integer length_to_limit;
1393
1393 length_to_limit:=512-(next_free mod 512);
1394 if length_to_limit<code_length then
1395 op:=next_free+length_to_limit-1
1396 else
1397 op:=next_free-1;
1398 next_free:=op+code_length+1;
1399 if next_free>=max_code then
1400 init_error(4);
1401 code.op(1):=opcode_nr shift 12 +(s_line extract 12);
1402 set_op:=next_free;
1403 end;
1404
1404 integer procedure find_string_address(string_length);
1405 <*----------------------------------------------------------------*>
1406 <* Find room to insert string_length hw's in the same *>
1407 <* segment starting at next_free *>
1408 <*----------------------------------------------------------------*>
1409 value string_length;
1410 integer string_length;
1411 begin
1412 integer length_to_limit,i;
1413
1413 length_to_limit:=512-(next_free mod 512);
1414 if string_length>length_to_limit then
1415 i:=next_free+length_to_limit
1416 else
1417 i:=next_free;
1418 find_string_address:=i;
1419 end;
1420
1420 procedure insert_jump(addr,jump);
1421 <*----------------------------------------------------------------*>
1422 <* Insert a jump op-code *>
1423 <*----------------------------------------------------------------*>
1424 value jump;
1425 integer field addr;
1426 integer jump;
1427 begin
1428 integer field next_addr;
1429
1429 while addr<>0 do
1430 begin
1431 next_addr:=code.addr;
1432 code.addr:=jump;
1433 addr:=next_addr;
1434 end;
1435 end;
1436
1436 procedure make_bool(f_addr,t_addr);
1437 <*----------------------------------------------------------------*>
1438 <* Producer kode for bool-exp *>
1439 <* returner peger til false og true *>
1440 <* adresse felterne i koden *>
1441 <*----------------------------------------------------------------*>
1442 integer field f_addr,t_addr;
1443 begin
1444 integer array left_string,right_string (1:max_string//3+5);
1445 boolean equal;
1446
1446 if -,make_string(left_string) then
1447 begin
1448 syntax_scan(1);
1449 goto end_bool;
1450 end;
1451 equal:=false;
1452 if token_type=t_equal then
1453 equal:=true
1454 else
1455 if token_type<>t_not then
1456 syntax_error(10);
1457 next_token;
1458 if -,make_string(right_string) then
1459 begin
1460 syntax_scan(1);
1461 goto end_bool;
1462 end;
1463 <* make bool-exp *>
1464 if (left_string(2) shift (-12)=1) and
1465 (right_string(2) shift (-12)=5) and
1466 (right_string(3) extract 12 <=3) then
1467 begin
1468 set_op(3,10);
1469 code.op(4):=(left_string(2) extract 12) shift 12 +
1470 (right_string(3) extract 12);
1471 code.op(5):=right_string(4);
1472 end
1473 else
1474 if (right_string(2) shift (-12)=1) and
1475 (left_string(2) shift (-12)=5) and
1476 (left_string(3) extract 12 <=3) then
1477 begin
1478 set_op(3,10);
1479 code.op(4):=(right_string(2) extract 12) shift 12 +
1480 (left_string(3) extract 12);
1481 code.op(5):=left_string(4);
1482 end
1483 else
1484 if right_string(2) shift (-12)=0 and
1485 left_string(2) shift (-12)=1 then
1486 begin
1487 set_op(3,10);
1488 code.op(4):=left_string(2) shift 12;
1489 code.op(5):=0;
1490 end
1491 else
1492 if left_string(2) shift (-12)=0 and
1493 right_string(2) shift (-12)=1 then
1494 begin
1495 set_op(3,10);
1496 code.op(4):=right_string(2) shift 12;
1497 code.op(5):=0;
1498 end
1499 else
1500 begin
1501 set_op(2,8+left_string(1));
1502 insert_string(left_string,op+9);
1503 code.op(4):=find_string_address(right_string(1));
1504 insert_string(right_string,code.op(4));
1505 end;
1506 if equal then
1507 begin
1508 f_addr:=op+6;
1509 t_addr:=op+4; <* true jump *>
1510 end
1511 else
1512 begin
1513 t_addr:=op+6; <* false jump *>
1514 f_addr:=op+4;
1515 end;
1516 end_bool:
1517 end;
1518
1518 procedure make_bool_exp(end_token_type,error_nr,f_addr,t_addr);
1519 <*----------------------------------------------------------------*>
1520 <* Producer kode for bool-exp ink. AND / OR *>
1521 <* returner peger til false og true *>
1522 <* adresse felterne i koden *>
1523 <*----------------------------------------------------------------*>
1524 integer end_token_type,error_nr;
1525 integer field f_addr,t_addr;
1526 begin
1527 integer prev_addr;
1528
1528 make_bool(f_addr,t_addr);
1529 while token_type=t_and or token_type=t_or do
1530 begin
1531 if token_type=t_and then
1532 begin
1533 insert_jump(t_addr,next_free);
1534 prev_addr:=f_addr;
1535 next_token;
1536 make_bool(f_addr,t_addr);
1537 code.f_addr:=prev_addr;
1538 end
1539 else
1540 if token_type=t_or then
1541 begin
1542 insert_jump(f_addr,next_free);
1543 prev_addr:=t_addr;
1544 next_token;
1545 make_bool(f_addr,t_addr);
1546 code.t_addr:=prev_addr;
1547 end
1548 end;
1549 if token_type=end_token_type then
1550 next_token
1551 else
1552 syntax_scan(error_nr);
1553 end;
1554
1554 boolean procedure make_string(st);
1555 <*----------------------------------------------------------------*>
1556 <* Find type of string and insert this in string array *>
1557 <* String array format: *>
1558 <* st(1) : Length of used string array exc. this element *>
1559 <* in half words. *>
1560 <* st(2) : String type in same format as cmcl code. *>
1561 <* st(3) : Text start (first word = HW < 12 + chars.) *>
1562 <*----------------------------------------------------------------*>
1563 integer array st;
1564 begin
1565 boolean interval,ok;
1566 integer first_char,num_of_char,var_ref,i;
1567
1567 make_string:=true;
1568 ok:=true;
1569 for ii:=system(3,i,st) step 1 until i do
1570 st(ii):=0;
1571 if token_type<t_string or token_type>t_var then
1572 begin
1573 ok:=false;
1574 goto make_string_end;
1575 end;
1576 if token_type=t_string then <* Text string *>
1577 begin
1578 long array la(1:max_string//6+3);
1579 integer i,ts_length;
1580 boolean tvs;
1581 ts_length:=token_string_length;
1582 tvs:=token_var_sub;
1583 if ts_length>max_string then
1584 begin
1585 mcl_error(2);
1586 ts_length:=max_string;
1587 end;
1588 for i:=1 step 1 until max_string//6+2 do
1589 la(i):=token_text(i);
1590 next_token;
1591 interval:=false;
1592 if token_type=t_int_start then
1593 begin <* Interval *>
1594 if -,tvs then
1595 warning(4);
1596 next_token;
1597 if token_type<>t_number then
1598 begin
1599 ok:=false;
1600 syntax_error(3);
1601 goto make_string_end;
1602 end;
1603 first_char:=token_number_val;
1604 if first_char<1 then
1605 begin
1606 first_char:=1;
1607 syntax_error(4);
1608 end;
1609 if first_char>max_string+20 then
1610 begin
1611 first_char:=max_string;
1612 syntax_error(4);
1613 end;
1614 next_token;
1615 if token_type<>t_number then
1616 begin
1617 ok:=false;
1618 syntax_error(3);
1619 goto make_string_end;
1620 end;
1621 num_of_char:=token_number_val;
1622 if num_of_char<1 then
1623 begin
1624 syntax_error(4);
1625 num_of_char:=1;
1626 end;
1627 next_token;
1628 if token_type<>t_int_end then
1629 begin
1630 ok:=false;
1631 syntax_error(5);
1632 goto make_string_end;
1633 end;
1634 next_token;
1635 interval:=true;
1636 end;
1637 if (ts_length=0) or
1638 (interval and -,tvs and (ts_length < first_char)) then
1639 begin <* Null string *>
1640 st(1):=2;
1641 st(2):=0;
1642 end
1643 else
1644 begin
1645 if -,(interval or tvs) then
1646 begin <* Constant string *>
1647 st(1):=4+((ts_length+2)//3*2);
1648 st(2):=5 shift 12;
1649 st(3):=(st(1)-2) shift 12 + ts_length;
1650 for i:=1 step 1 until (st(1)-2)//4 do
1651 begin
1652 st(2*i+2):=la(i) shift (-24);
1653 st(2*i+3):=la(i) extract 24;
1654 end;
1655 end;
1656 if tvs and -,interval then
1657 begin <* Text with varsub *>
1658 st(1):=4+((ts_length+2)//3*2);
1659 st(2):=3 shift 12;
1660 st(3):=(st(1)-2) shift 12 + ts_length;
1661 for i:=1 step 1 until (st(1)-2)//4 do
1662 begin
1663 st(2*i+2):=la(i) shift (-24);
1664 st(2*i+3):=la(i) extract 24;
1665 end;
1666 end;
1667 if tvs and interval then
1668 begin
1669 st(1):=6+((ts_length+2)//3*2);
1670 st(2):=4 shift 12;
1671 st(3):=first_char shift 12 + num_of_char;
1672 st(4):=(st(1)-4) shift 12 + ts_length;
1673 for i:=1 step 1 until (st(1)-4)//4 do
1674 begin
1675 st(2*i+3):=la(i) shift (-24);
1676 st(2*i+4):=la(i) extract 24;
1677 end;
1678 end;
1679 if interval and -,tvs then
1680 begin <* Constant string with interval !!!!! *>
1681 integer new_length,sti,li,ch,index;
1682
1682 new_length:=if (ts_length-first_char+1)>=num_of_char then
1683 num_of_char
1684 else
1685 ts_length-first_char+1;
1686 sti:=0;
1687 <* move new_length characters from la to st *>
1688 <* starting at character first_char in la *>
1689 for li:=first_char-1 step 1 until first_char+new_length-2 do
1690 begin
1691 <* find character li+1 in la *>
1692 ch:=(la(li//6+1) shift (-8*(5-(li mod 6)))) extract 8;
1693 index:=sti//3+4;
1694 <* insert character in st at sti+1 *>
1695 st(index):=st(index) + (ch shift (8*(2-(sti mod 3))));
1696 sti:=sti+1;
1697 end;
1698 st(1):=4+((new_length+2)//3*2);
1699 st(2):=5 shift 12;
1700 st(3):=(st(1)-2) shift 12 + new_length;
1701 end;
1702 end;
1703 end <* Text string *>
1704 else
1705 begin <* Variable or illegal string *>
1706 var_ref:=token_number_val;
1707 if token_type=t_errstring then
1708 syntax_error(1);
1709 next_token;
1710 if token_type=t_int_start then
1711 begin <* Interval *>
1712 next_token;
1713 if token_type<>t_number then
1714 begin
1715 ok:=false;
1716 syntax_error(3);
1717 goto make_string_end;
1718 end;
1719 first_char:=token_number_val;
1720 if first_char<1 then
1721 begin
1722 first_char:=1;
1723 syntax_error(4);
1724 end;
1725 if first_char>max_string+20 then
1726 begin
1727 first_char:=max_string;
1728 syntax_error(4);
1729 end;
1730 next_token;
1731 if token_type<>t_number then
1732 begin
1733 ok:=false;
1734 syntax_error(3);
1735 goto make_string_end;
1736 end;
1737 num_of_char:=token_number_val;
1738 if num_of_char<1 then
1739 begin
1740 syntax_error(4);
1741 num_of_char:=1;
1742 end;
1743 if num_of_char>max_string+20 then
1744 begin
1745 syntax_error(4);
1746 num_of_char:=max_string;
1747 end;
1748 next_token;
1749 if token_type<>t_int_end then
1750 begin
1751 ok:=false;
1752 syntax_error(5);
1753 goto make_string_end;
1754 end;
1755 next_token;
1756 st(1):=4;
1757 st(2):=2 shift 12 + var_ref;
1758 st(3):=first_char shift 12 + num_of_char;
1759 end
1760 else
1761 begin <* No interval *>
1762 st(1):=2;
1763 st(2):= 1 shift 12 + var_ref;
1764 end;
1765 end;
1766 make_string_end:
1767 if -,ok then
1768 begin
1769 st(1):=2;
1770 st(2):=0; <* Empty string *>
1771 make_string:=false;
1772 while token_type=t_int_end or token_type=t_number do
1773 next_token;
1774 end;
1775 end;
1776
1776 boolean procedure make_const_string(cst,point);
1777 <*----------------------------------------------------------------*>
1778 <* Find constant string and insert this in const *>
1779 <* string array. *>
1780 <* const string array format: *>
1781 <* cst(1) : Number of char in text. *>
1782 <* cst(2) : First char. in text. Converted to capital letter *>
1783 <* cst(3) : Start of text *>
1784 <*----------------------------------------------------------------*>
1785 integer array cst;
1786 boolean point;
1787 begin
1788 integer i,j;
1789 for i:=system(3,j,cst) step 1 until j do
1790 cst(i):=0;
1791 if token_type=t_errstring then
1792 begin
1793 syntax_error(1);
1794 cst(1):=cst(2):=cst(3):=0;
1795 end
1796 else
1797 if token_type<>t_string then
1798 begin
1799 make_const_string:=false;
1800 cst(1):=cst(2):=cst(3):=0;
1801 end
1802 else
1803 begin
1804 make_const_string:=true;
1805 if token_var_sub then
1806 mcl_error(3); <* Not constant *>
1807 if token_string_length=0 then
1808 cst(1):=cst(2):=cst(3):=0
1809 else
1810 begin
1811 if token_string_length>max_string then
1812 begin
1813 mcl_error(2);
1814 token_string_length:=max_string;
1815 end;
1816 cst(1):=token_string_length;
1817 cst(2):=token_text(1) shift (-40);
1818 for i:=1 step 1 until cst(1)//6+1 do
1819 begin
1820 cst(2*i+1):=token_text(i) shift (-24);
1821 cst(2*i+2):=token_text(i) extract 24;
1822 end;
1823 end;
1824 if cst(2)>='a' and cst(2)<='å' then
1825 cst(2):=cst(2)-32;
1826 if token_string_length=0 and point then
1827 mcl_error(4);
1828 next_token;
1829 end;
1830 end;
1831
1831 integer procedure insert_string(st,addr);
1832 <*----------------------------------------------------------------*>
1833 <* Insert st (string) in code at address addr *>
1834 <* Return next unused address in next_free *>
1835 <*----------------------------------------------------------------*>
1836 value addr;
1837 integer array st;
1838 integer addr;
1839 begin
1840 integer i;
1841 integer array field p;
1842
1842 p:=addr-1;
1843 for i:=2 step 1 until st(1)//2+1 do
1844 code.p(i-1):=st(i);
1845 insert_string:=next_free:=addr+st(1);
1846 end;
1847
1847 procedure select;
1848 <*----------------------------------------------------------------*>
1849 <* Produce code for SELECT *>
1850 <* Structure of produced kode: *>
1851 <*
1852 -- bool exp -- ___
1853 true address -- *
1854 !----false address ! *
1855 ! -------------- ! *
1856 ! <--! *
1857 ! Action * First CASE
1858 ! *
1859 ! ---- jump ---- *
1860 ! address ---! *
1861 ! -------------- ! __*
1862 !--> ! --*
1863 ! * More cases
1864 ! *
1865 -------------- ! --*
1866 otherwise !
1867 action !
1868 -------------- !
1869 <--!
1870 *>
1871 <*----------------------------------------------------------------*>
1872 begin
1873 integer f_jump_hold_addr,
1874 t_jump_hold_addr,
1875 jump_hold_addr,
1876 string_start;
1877 integer field i;
1878 integer var_ref;
1879 integer array case_string(1:max_string//3+5);
1880
1880 f_jump_hold_addr:=jump_hold_addr:=0;
1881 if token_type<>t_var then
1882 begin
1883 syntax_scan(6);
1884 goto case_start;
1885 end;
1886 var_ref:=token_number_val;
1887 next_token;
1888 if token_type<>t_of then
1889 begin
1890 syntax_scan(7);
1891 goto case_start;
1892 end;
1893 next_token;
1894 if token_type<>t_case then
1895 syntax_scan(8);
1896 case_start:
1897 while token_type=t_case do <* case *>
1898 begin
1899 s_line:=line_number;
1900 next_token;
1901 if f_jump_hold_addr<>0 then
1902 begin
1903 <* Indsæt adresse på ny bool-exp start i forrige bool-exp *>
1904 i:=f_jump_hold_addr;
1905 code.i:=next_free;
1906 end;
1907 if -,make_string(case_string) then
1908 syntax_scan(1);
1909 <* Indsæt bool-exp ud fra var_ref og case_string *>
1910 if (case_string(2) shift (-12)=5) and
1911 (case_string(3) extract 12<=3) then
1912 begin
1913 set_op(3,10);
1914 code.op(4):=var_ref shift 12 +(case_string(3) extract 12);
1915 code.op(5):=case_string(4);
1916 end
1917 else
1918 if (case_string(2) shift (-12)=0) then
1919 begin
1920 set_op(3,10);
1921 code.op(4):=var_ref shift 12;
1922 code.op(5):=0;
1923 end
1924 else
1925 begin
1926 set_op(2,10);
1927 code.op(5):=1 shift 12 + var_ref;
1928 string_start:=find_string_address(case_string(1));
1929 code.op(4):=string_start;
1930 insert_string(case_string,string_start);
1931 end;
1932 code.op(2):=next_free;
1933 f_jump_hold_addr:=op+6;
1934 action;
1935 s_line:=line_number;
1936 <* Indsæt JUMP code efter action *>
1937 set_op(1,4);
1938 code.op(2):=jump_hold_addr;
1939 jump_hold_addr:=op+4;
1940 end;
1941 if token_type=t_otherwise then
1942 begin <* otherwise *>
1943 <* Indsæt adresse på otherwise i sidste bool-exp *>
1944 if make_code then
1945 begin
1946 i:=f_jump_hold_addr;
1947 code.i:=next_free;
1948 end;
1949 next_token;
1950 action;
1951 end
1952 else
1953 if make_code then
1954 begin <* fjern sidste jump *>
1955 next_free:=next_free-4;
1956 jump_hold_addr:=code.op(2);
1957 code.op(1):=code.op(2):=0;
1958 <* Indsæt adresse på endselect i sidste bool-exp *>
1959 i:=f_jump_hold_addr;
1960 code.i:=next_free;
1961 end;
1962 <*Indsæt baglens i jump_hold_adr addressen på første sætning efter select *>
1963 if make_code then
1964 while jump_hold_addr<>0 do
1965 begin
1966 i:=jump_hold_addr;
1967 jump_hold_addr:=code.i;
1968 code.i:=next_free;
1969 end;
1970 if token_type<>t_endselect then
1971 syntax_error(9)
1972 else
1973 next_token; <* find first token after SELECT *>
1974 select_end:
1975 end; <* select *>
1976
1976 procedure while_sentence;
1977 <*----------------------------------------------------------------*>
1978 <* Produce code for WHILE *>
1979 <* Structure of produced kode *>
1980 <*
1981 -- bool exp --
1982 <-------!
1983 true address -- !
1984 !----false address ! !
1985 ! -------------- ! !
1986 ! <--! !
1987 ! action !
1988 ! !
1989 ! ---- jump ---- !
1990 ! address ---------
1991 ! --------------
1992 !-->
1993 *>
1994 <*----------------------------------------------------------------*>
1995 begin
1996 integer prev_while_start;
1997 integer field f_jump_hold_addr,t_jump_hold_addr;
1998 boolean equal;
1999
1999 prev_while_start:=while_start;
2000 while_start:=next_free;
2001 make_bool_exp(t_do,11,f_jump_hold_addr,t_jump_hold_addr);
2002 if make_code then
2003 insert_jump(t_jump_hold_addr,next_free);
2004 first_action:
2005 action;
2006 s_line:=line_number;
2007 <* Insert jump code to while start *>
2008 set_op(1,4);
2009 code.op(2):=while_start;
2010 if make_code then
2011 insert_jump(f_jump_hold_addr,next_free);
2012 while_start:=prev_while_start;
2013 if token_type<>t_endwhile then
2014 begin
2015 syntax_error(12);
2016 end
2017 else
2018 next_token;
2019 end;
2020
2020 procedure menu;
2021 <*----------------------------------------------------------------*>
2022 <* Produce code for MENU *>
2023 <*----------------------------------------------------------------*>
2024 begin
2025 integer field end_hold_addr,i;
2026 integer col,line,num_of_point,menu_text_index,
2027 ch_index,text_length,ncol;
2028 integer array menu_text(1:640),point_table(1:3*25);
2029 integer array field entry,menu_op;
2030 integer array menu_line(1:max_string//3+5);
2031 boolean first_text,ctrls;
2032 boolean array unique(0:127);
2033
2033
2033 procedure next_line;
2034 <* Insert NL in menu text *>
2035 begin
2036 if menu_line(2)>31 then
2037 begin
2038 line:=line+1;
2039 if line>24 then
2040 warning(2);
2041 pack_char(10);
2042 end;
2043 end;
2044
2044 procedure pack_char(ch);
2045 <* Insert a character in menu text *>
2046 value ch;
2047 integer ch;
2048 begin
2049 menu_text(menu_text_index):=menu_text(menu_text_index)+
2050 (ch shift (8*ch_index));
2051 ch_index:=ch_index-1;
2052 if ch_index=-1 then
2053 begin
2054 menu_text_index:=menu_text_index+1;
2055 if menu_text_index>640 then
2056 comp_error(9);
2057 ch_index:=2;
2058 end;
2059 end;
2060
2060 procedure pack_const_string(cst);
2061 <* Indsert string in cst in menu text *>
2062 integer array cst;
2063 begin
2064 integer i,cst_text_index,cst_ch_index;
2065
2065 cst_text_index:=0;
2066 cst_ch_index:=-2;
2067 for i:=1 step 1 until cst(1) do
2068 begin
2069 pack_char((cst(3+cst_text_index) shift (cst_ch_index*8)) extract 8);
2070 cst_ch_index:=cst_ch_index+1;
2071 if cst_ch_index=1 then
2072 begin
2073 cst_text_index:=cst_text_index+1;
2074 cst_ch_index:=-2;
2075 end;
2076 end;
2077 end;
2078
2078 if token_type<>t_number then
2079 begin
2080 syntax_error(3);
2081 col:=line:=-1;
2082 goto point_start;
2083 end;
2084 col:=token_number_val;
2085 if col>79 then
2086 begin
2087 mcl_error(6);
2088 col:=79;
2089 end;
2090 next_token;
2091 if token_type<>t_number then
2092 begin
2093 syntax_error(3);
2094 col:=line:=-1;
2095 goto point_start;
2096 end;
2097 line:=token_number_val;
2098 if line>24 then
2099 begin
2100 mcl_error(7);
2101 line:=1;
2102 end;
2103 next_token;
2104 if -,make_const_string(menu_line,false) then
2105 begin
2106 syntax_error(1);
2107 line:=col:=-1;
2108 end;
2109 set_op(22,8);
2110 code.op(2):=line shift 12;
2111 point_start:
2112 if token_type>t_endinclude then
2113 begin
2114 if col<>-1 then
2115 syntax_error(13);
2116 menu_line(1):=menu_line(2):=1;
2117 while token_type>t_endinclude do
2118 next_token;
2119 end;
2120 menu_op:=op; <* Rem. menu code pos. *>
2121 menu_text_index:=1;
2122 for i:=1 step 1 until 640 do
2123 menu_text(i):=0;
2124 ch_index:=2;
2125 end_hold_addr:=0;
2126 num_of_point:=0;
2127 if menu_line(1)>0 and menu_line(2)>31 then
2128 begin <* Write headline centred in 80 char. *>
2129 for i:=1 step 1 until (80-menu_line(1))//2 do
2130 pack_char(32);
2131 pack_const_string(menu_line);
2132 end;
2133 line:=line+1;
2134 for ii:=0 step 1 until 127 do
2135 unique(ii):=false;
2136 ctrls:=true;
2137 while token_type=t_point or token_type=t_text do
2138 begin <* POINT and TEXT *>
2139 if token_type=t_text then
2140 begin <* TEXT *>
2141 next_token;
2142 if token_type=t_at then
2143 begin
2144 next_token;
2145 if token_type<>t_number then
2146 syntax_scan(3)
2147 else
2148 begin
2149 ncol:=token_number_val;
2150 if ncol>79 then
2151 begin
2152 mcl_error(6);
2153 ncol:=1;
2154 end;
2155 end;
2156 next_token;
2157 end
2158 else
2159 ncol:=col;
2160 if -,make_const_string(menu_line,false) then
2161 syntax_scan(1);
2162 next_line;
2163 if menu_line(1)>0 and menu_line(2)>31 then
2164 begin <* Insert text at collum ncol *>
2165 for i:=1 step 1 until ncol do
2166 pack_char(32);
2167 pack_const_string(menu_line);
2168 end;
2169 if menu_line(1)=0 then
2170 begin
2171 menu_line(2):=32;
2172 next_line;
2173 end;
2174 end
2175 else
2176 begin <* POINT *>
2177 integer entry_type;
2178 num_of_point:=num_of_point+1;
2179 if num_of_point>25 then
2180 begin
2181 num_of_point:=1;
2182 syntax_error(14);
2183 end;
2184 entry:=(num_of_point-1)*6;
2185 next_token;
2186 <* if token_type=t_at then
2187 begin
2188 next_token;
2189 if token_type<>t_number then
2190 syntax_scan(3)
2191 else
2192 begin
2193 ncol:=token_number_val;
2194 if ncol>79 then
2195 begin
2196 mcl_error(6);
2197 ncol:=1;
2198 end;
2199 end;
2200 next_token;
2201 end
2202 else *>
2203 ncol:=col;
2204 if -,make_const_string(menu_line,true) then
2205 syntax_scan(1);
2206 if unique(menu_line(2)) then
2207 mcl_error(10);
2208 unique(menu_line(2)):=true;
2209 point_table.entry(2):=ncol shift 12 + line;
2210 next_line;
2211 if menu_line(1)>0 and menu_line(2)>31 then
2212 begin <*Insert text at collum ncol *>
2213 for i:=1 step 1 until ncol do
2214 pack_char(32);
2215 pack_const_string(menu_line);
2216 ctrls:=false; <* Printeble menu point used *>
2217 end;
2218 <* Find entry type bits *>
2219 entry_type:=0;
2220 if num_of_point=1 then
2221 entry_type:=1; <* Top bit *>
2222 if menu_line(2)<32 then
2223 entry_type:=entry_type+8; <* Ctlr char bit *>
2224 point_table.entry(1):=menu_line(2) shift 12 + entry_type;
2225 point_table.entry(3):=next_free; <* Action address *>
2226 action;
2227 s_line:=line_number;
2228 set_op(1,4); <* Insert jump to end-menu after action code *>
2229 code.op(2):=end_hold_addr;
2230 end_hold_addr:=op+4;
2231 end;
2232 if token_type>t_endinclude then
2233 begin
2234 syntax_error(15);
2235 while token_type>t_endinclude do
2236 next_token;
2237 end;
2238 end; <* point and text *>
2239 <* Indsert bottom bit in last entry *>
2240 if num_of_point>0 then
2241 begin
2242 entry:=6*(num_of_point-1);
2243 point_table.entry(1):=point_table.entry(1)+2;
2244 end
2245 else
2246 mcl_error(1);
2247 if ctrls then <* Only controls are used in points *>
2248 mcl_error(1);
2249 <* Insert last menu line in all ctrl point *>
2250 for entry:=0 step 6 until 6*(num_of_point-1) do
2251 if (point_table.entry(1) shift (-12))<32 then
2252 point_table.entry(2):=col shift 12 + line;
2253 <* Find menu text length *>
2254 text_length:=3*(menu_text_index-1)+(2-ch_index);
2255 first_text:=true;
2256 menu_text_index:=0;
2257 while text_length>0 do
2258 begin <* Insert menu text entries *>
2259 integer room;
2260 room:=512-(next_free mod 512);
2261 if (room<20) and (((text_length//3)*2+4)>room) then
2262 begin <* No room for text; min. 30 char in one text-entry *>
2263 next_free:=next_free+room;
2264 room:=512;
2265 end;
2266 if first_text then
2267 code.menu_op(4):=next_free; <* Insert address of first text *>
2268 entry:=next_free-1; <* Entry in code *>
2269 first_text:=false;
2270 if ((text_length//3)*2+4)<room then
2271 begin <* Last text entry *>
2272 code.entry(1):=0;
2273 code.entry(2):=((text_length+2)//3+1)*2 shift 12 + text_length;
2274 end
2275 else
2276 begin
2277 code.entry(1):=next_free+room; <* Next text start *>
2278 code.entry(2):=(room-2) shift 12 + ((room-4)//2)*3;
2279 end;
2280 for i:=1 step 1 until (code.entry(2) shift (-12))//2 do
2281 code.entry(2+i):=menu_text(i+menu_text_index);
2282 next_free:=next_free+(code.entry(2) shift (-12))+2;
2283 text_length:=text_length-code.entry(2) extract 12;
2284 menu_text_index:=menu_text_index+(code.entry(2) extract 12)//3;
2285 end;
2286 <* Find room for point table (max. 150 hw) *>
2287 entry:=find_string_address(6*num_of_point)-1;
2288 code.menu_op(3):=entry+1; <* Insert address of first point *>
2289 for i:=1 step 1 until 3*num_of_point do
2290 code.entry(i):=point_table(i);
2291 next_free:=entry+1+6*num_of_point;
2292 code.menu_op(2):=code.menu_op(2)+num_of_point;
2293 <* indsæt i end_hold_jump *>
2294 if make_code then
2295 while end_hold_addr<>0 do
2296 begin
2297 i:=end_hold_addr;
2298 end_hold_addr:=code.i;
2299 code.i:=next_free;
2300 end;
2301 if token_type<>t_endmenu then
2302 syntax_error(15)
2303 else
2304 next_token;
2305 end; <* menu *>
2306
2306 procedure attention;
2307 <*----------------------------------------------------------------*>
2308 <* Produce code for ATTENTION *>
2309 <*----------------------------------------------------------------*>
2310 begin
2311 integer field end_att_hold_addr;
2312 integer array proc_string(1:max_string//3+5);
2313
2313 if in_attention or in_include then
2314 mcl_error(9);
2315 in_attention:=true;
2316 att_start:=next_free;
2317 if -,make_string(proc_string) then
2318 begin
2319 syntax_scan(1);
2320 goto first_action;
2321 end;
2322 set_op(4,10+proc_string(1));
2323 insert_string(proc_string,op+9);
2324 code.op(2):=next_free;
2325 if token_type<>t_var then
2326 begin
2327 syntax_scan(6);
2328 goto first_action;
2329 end;
2330 code.op(4):=token_number_val shift 12;
2331 end_att_hold_addr:=op+6;
2332 next_token;
2333 first_action:
2334 action;
2335 if make_code then
2336 code.end_att_hold_addr:=next_free;
2337 s_line:=line_number;
2338 set_op(5,2);
2339 in_attention:=false;
2340 if token_type<>t_endattention then
2341 syntax_error(16)
2342 else
2343 next_token;
2344 end;
2345
2345 procedure include;
2346 <*----------------------------------------------------------------*>
2347 <* Produce code for INCLUDE *>
2348 <*----------------------------------------------------------------*>
2349 begin
2350 integer field end_inc_hold_addr;
2351 integer array proc_string,pool_string,local_string(1:max_string//3+5);
2352 integer bufs;
2353
2353 if in_attention or in_include then
2354 mcl_error(9);
2355 in_include:=true;
2356 att_start:=next_free;
2357 if -,make_string(pool_string) then
2358 begin
2359 syntax_scan(1);
2360 goto first_action;
2361 end;
2362 if -,make_string(proc_string) then
2363 begin
2364 syntax_scan(1);
2365 goto first_action;
2366 end;
2367 if -,make_string(local_string) then
2368 begin
2369 syntax_scan(1);
2370 goto first_action;
2371 end;
2372 set_op(6,16+local_string(1));
2373 insert_string(local_string,op+15);
2374 code.op(6):=find_string_address(pool_string(1));
2375 insert_string(pool_string,code.op(6));
2376 code.op(7):=find_string_address(proc_string(1));
2377 insert_string(proc_string,code.op(7));
2378 code.op(2):=next_free;
2379 if token_type<>t_number then
2380 begin
2381 syntax_scan(3);
2382 goto first_action;
2383 end;
2384 bufs:=token_number_val;
2385 if bufs>1 then
2386 mcl_error(5);
2387 next_token;
2388 if token_type<>t_number then
2389 begin
2390 syntax_scan(3);
2391 goto first_action;
2392 end;
2393 code.op(5):=bufs shift 12 + token_number_val;
2394 next_token;
2395 if token_type<>t_var then
2396 begin
2397 syntax_scan(6);
2398 goto first_action;
2399 end;
2400 code.op(4):=token_number_val shift 12;
2401 end_inc_hold_addr:=op+6;
2402 next_token;
2403 first_action:
2404 action;
2405 if make_code then
2406 code.end_inc_hold_addr:=next_free;
2407 s_line:=line_number;
2408 set_op(7,2);
2409 in_include:=false;
2410 if token_type<>t_endinclude then
2411 syntax_error(17)
2412 else
2413 next_token;
2414 end;
2415
2415 procedure at;
2416 <*----------------------------------------------------------------*>
2417 <* Produce code for AT *>
2418 <*----------------------------------------------------------------*>
2419 begin
2420 integer col,line;
2421
2421 if token_type<>t_number then
2422 syntax_scan(3)
2423 else
2424 begin
2425 col:=token_number_val;
2426 if col>79 then
2427 begin
2428 mcl_error(6);
2429 col:=79;
2430 end;
2431 next_token;
2432 if token_type=t_number then
2433 begin
2434 line:=token_number_val;
2435 if line>24 then
2436 begin
2437 mcl_error(7);
2438 line:=24;
2439 end;
2440 next_token;
2441 end
2442 else
2443 begin
2444 line:=-1;
2445 if token_type>t_echo then
2446 syntax_scan(18);
2447 end;
2448 set_op(8,4);
2449 code.op(2):=col shift 12 + (line extract 12);
2450 end;
2451 end;
2452
2452 procedure write_sentence;
2453 <*----------------------------------------------------------------*>
2454 <* Produce code for WRITE *>
2455 <*----------------------------------------------------------------*>
2456 begin
2457 integer array write_string(1:max_string//3+5);
2458
2458 if -,make_string(write_string) then
2459 syntax_scan(1)
2460 else
2461 if write_string(2) shift (-12) <> 0 then
2462 begin <* Non empty string *>
2463 set_op(9,6+write_string(1));
2464 insert_string(write_string,op+5);
2465 code.op(2):=next_free;
2466 end;
2467 end;
2468
2468 procedure nl;
2469 <*----------------------------------------------------------------*>
2470 <* Produce code for NL *>
2471 <*----------------------------------------------------------------*>
2472 begin
2473 set_op(10,2);
2474 end;
2475
2475 procedure erase;
2476 <*----------------------------------------------------------------*>
2477 <* Produce code for ERASE *>
2478 <*----------------------------------------------------------------*>
2479 begin
2480 set_op(23,2);
2481 end;
2482
2482 procedure read_sentence;
2483 <*----------------------------------------------------------------*>
2484 <* Produce code for READ *>
2485 <*----------------------------------------------------------------*>
2486 begin
2487 integer array read_string(1:max_string//3+5);
2488 integer char_to_read;
2489
2489 if -,make_string(read_string) then
2490 syntax_scan(1)
2491 else
2492 if token_type<>t_number then
2493 char_to_read:=-1
2494 else
2495 begin
2496 char_to_read:=token_number_val;
2497 if char_to_read>max_string or char_to_read<1 then
2498 begin
2499 mcl_error(5);
2500 char_to_read:=1;
2501 end;
2502 next_token;
2503 end;
2504 if token_type<>t_var then
2505 syntax_scan(6)
2506 else
2507 begin
2508 if read_string(2) shift (-12) <> 0 then
2509 begin <* Non empty string *>
2510 set_op(9,6+read_string(1));
2511 insert_string(read_string,op+5);
2512 code.op(2):=next_free;
2513 end;
2514 set_op(11,4);
2515 code.op(2):=char_to_read shift 12 + token_number_val;
2516 next_token;
2517 end;
2518 end;
2519
2519
2519 procedure get;
2520 <*----------------------------------------------------------------*>
2521 <* Produce code for GET *>
2522 <*----------------------------------------------------------------*>
2523 begin
2524 integer char_to_get;
2525
2525 if -,(in_attention or in_include) then
2526 warning(1);
2527 if token_type<>t_number then
2528 syntax_scan(3)
2529 else
2530 begin
2531 char_to_get:=token_number_val;
2532 if char_to_get>max_string or char_to_get<1 then
2533 mcl_error(5);
2534 next_token;
2535 if token_type<>t_var then
2536 syntax_scan(6)
2537 else
2538 begin
2539 set_op(12,4);
2540 code.op(2):=char_to_get shift 12 + token_number_val;
2541 next_token;
2542 end;
2543 end;
2544 end;
2545
2545 procedure let;
2546 <*----------------------------------------------------------------*>
2547 <* Produce code for LET *>
2548 <*----------------------------------------------------------------*>
2549 begin
2550 integer var_ref;
2551 integer array let_string(1:max_string//3+5);
2552
2552 if token_type<>t_var then
2553 syntax_scan(6)
2554 else
2555 begin
2556 var_ref:=token_number_val;
2557 next_token;
2558 if token_type<>t_equal then
2559 syntax_scan(10)
2560 else
2561 begin
2562 next_token;
2563 if -,make_string(let_string) then
2564 syntax_scan(1)
2565 else
2566 begin
2567 set_op(13,8+let_string(1));
2568 insert_string(let_string,op+7);
2569 code.op(2):=next_free;
2570 code.op(3):=var_ref shift 12;
2571 end;
2572 end;
2573 end;
2574 end;
2575
2575
2575 procedure send;
2576 <*----------------------------------------------------------------*>
2577 <* Produce code for SEND *>
2578 <*----------------------------------------------------------------*>
2579 begin
2580 integer array send_string(1:max_string//3+5);
2581
2581 if -,(in_attention or in_include) then
2582 warning(1);
2583 if -,make_string(send_string) then
2584 syntax_scan(1)
2585 else
2586 begin
2587 set_op(14,6+send_string(1));
2588 insert_string(send_string,op+5);
2589 code.op(2):=next_free;
2590 end;
2591 end;
2592
2592 procedure if_sentence;
2593 <*----------------------------------------------------------------*>
2594 <* Produce code for IF *>
2595 <* Structure of produced kode for IF THEN ELSE *>
2596 <*
2597 -- bool exp --
2598 true address --
2599 !----false address !
2600 ! -------------- !
2601 ! <--!
2602 ! action
2603 !
2604 ! ---- jump ----
2605 ! address ---!
2606 ! -------------- !
2607 !--> else !
2608 action !
2609 -------------- !
2610 <--!
2611
2611 Structure of produced kode for IF THEN
2612
2612 -- bool exp --
2613 true address --
2614 !----false address !
2615 ! -------------- !
2616 ! <--!
2617 ! action
2618 !
2619 ! --------------
2620 !-->
2621 *>
2622 <*----------------------------------------------------------------*>
2623 begin
2624 integer field f_jump_hold_addr,t_jump_hold_addr;
2625 boolean equal;
2626
2626 make_bool_exp(t_then,19,f_jump_hold_addr,t_jump_hold_addr);
2627 if make_code then
2628 insert_jump(t_jump_hold_addr,next_free);
2629 first_action:
2630 action;
2631 s_line:=line_number;
2632 if token_type=t_else then
2633 begin
2634 set_op(1,4);
2635 if make_code then
2636 insert_jump(f_jump_hold_addr,next_free);
2637 f_jump_hold_addr:=op+3;
2638 next_token;
2639 action;
2640 end;
2641 if make_code then
2642 insert_jump(f_jump_hold_addr,next_free);
2643 if token_type<>t_endif then
2644 begin
2645 syntax_error(20);
2646 end
2647 else
2648 next_token;
2649 end;
2650
2650 procedure execute;
2651 <*----------------------------------------------------------------*>
2652 <* Produce code for EXECUTE *>
2653 <*----------------------------------------------------------------*>
2654 begin
2655 integer array execute_string(1:max_string//3+5);
2656
2656 if -,make_string(execute_string) then
2657 syntax_scan(1)
2658 else
2659 begin
2660 set_op(15,8+execute_string(1));
2661 insert_string(execute_string,op+7);
2662 code.op(2):=next_free;
2663 if token_type<>t_var then
2664 syntax_scan(6)
2665 else
2666 begin
2667 code.op(3):=token_number_val shift 12;
2668 next_token;
2669 end;
2670 end;
2671 end;
2672
2672
2672 procedure note;
2673 <*----------------------------------------------------------------*>
2674 <* Produce code for NOTE *>
2675 <*----------------------------------------------------------------*>
2676 begin
2677 integer array note_string(1:max_string//3+5);
2678
2678 if -,make_string(note_string) then
2679 syntax_scan(1)
2680 else
2681 if use_note then
2682 begin
2683 set_op(9,6+note_string(1));
2684 insert_string(note_string,op+5);
2685 code.op(2):=next_free;
2686 set_op(10,2);
2687 end;
2688 end;
2689
2689 procedure direct;
2690 <*----------------------------------------------------------------*>
2691 <* Produce code for DIRECT *>
2692 <*----------------------------------------------------------------*>
2693 begin
2694 if -,(in_attention or in_include) then
2695 warning(1);
2696 if token_type<>t_var then
2697 syntax_scan(6)
2698 else
2699 begin
2700 set_op(16,4);
2701 code.op(2):=token_number_val shift 12;
2702 next_token;
2703 end;
2704 end;
2705
2705 procedure loop;
2706 <*----------------------------------------------------------------*>
2707 <* Produce code for LOOP *>
2708 <*----------------------------------------------------------------*>
2709 begin
2710 if in_attention and (while_start<att_start) then
2711 set_op(5,2);
2712 if in_include and (while_start<att_start) then
2713 set_op(5,2);
2714 set_op(1,4);
2715 code.op(2):=while_start;
2716 end;
2717
2717 procedure exit;
2718 <*----------------------------------------------------------------*>
2719 <* Produce code for EXIT *>
2720 <*----------------------------------------------------------------*>
2721 begin
2722 integer array exit_string(1:max_string//3+5);
2723
2723 if in_attention then
2724 set_op(5,2);
2725 if in_include then
2726 set_op(7,2);
2727 if -,make_string(exit_string) then
2728 syntax_scan(1);
2729 set_op(17,2+exit_string(1));
2730 insert_string(exit_string,op+3);
2731 end;
2732
2732 procedure output;
2733 <*----------------------------------------------------------------*>
2734 <* Produce code for OUTPUT *>
2735 <*----------------------------------------------------------------*>
2736 begin
2737 if token_type=t_on then
2738 begin
2739 next_token;
2740 set_op(18,2);
2741 end
2742 else
2743 if token_type=t_off then
2744 begin
2745 next_token;
2746 set_op(19,2);
2747 end
2748 else
2749 syntax_scan(21);
2750 end;
2751
2751 procedure echo;
2752 <*----------------------------------------------------------------*>
2753 <* Produce code for ECHO *>
2754 <*----------------------------------------------------------------*>
2755 begin
2756 if token_type=t_on then
2757 begin
2758 next_token;
2759 set_op(20,2);
2760 end
2761 else
2762 if token_type=t_off then
2763 begin
2764 next_token;
2765 set_op(21,2);
2766 end
2767 else
2768 syntax_scan(21);
2769 end;
2770
2770 procedure convert;
2771 <*----------------------------------------------------------------*>
2772 <* Produce code for CONVERT *>
2773 <*----------------------------------------------------------------*>
2774 begin
2775 if token_type<>t_var then
2776 syntax_scan(6)
2777 else
2778 begin
2779 set_op(24,4);
2780 code.op(2):=token_number_val shift 12;
2781 next_token;
2782 end;
2783 end;
2784
2784
2784
2784 procedure action;
2785 <*----------------------------------------------------------------*>
2786 <* Call procedures to produce code for the *>
2787 <* sentence in a action, return if next keyword *>
2788 <* is a 'action-end' *>
2789 <*----------------------------------------------------------------*>
2790 begin
2791 integer tt;
2792 while token_type>t_endinclude do
2793 begin
2794 if (token_type>=t_select) and (token_type<=t_echo) then
2795 begin
2796 tt:=token_type-t_endinclude;
2797 s_line:=line_number;
2798 next_token;
2799 case tt of
2800 begin
2801 select;
2802 while_sentence;
2803 menu;
2804 attention;
2805 include;
2806 at;
2807 write_sentence;
2808 nl;
2809 erase;
2810 read_sentence;
2811 get;
2812 let;
2813 send;
2814 if_sentence;
2815 execute;
2816 note;
2817 direct;
2818 loop;
2819 exit;
2820 output;
2821 convert;
2822 echo
2823 end;
2824 end;
2825 if token_type>t_echo then
2826 begin
2827 <* Error, not a sentence start *>
2828 if token_type=t_unknown then <* Unknown keyword *>
2829 begin
2830 next_token;
2831 syntax_scan(2);
2832 end
2833 else
2834 syntax_scan(18);
2835 end;
2836 end; <* Other = end action *>
2837 end;
2838
2838 integer procedure list_string(addr);
2839 <*----------------------------------------------------------------*>
2840 <* Used by list-code. List string format *>
2841 <* starting at address addr *>
2842 <*----------------------------------------------------------------*>
2843 value addr;
2844 integer addr;
2845 begin
2846 integer type;
2847 integer field i;
2848
2848 write(out,<:<10>:>,<<dddddd>,addr,<:+ :>);
2849 i:=addr+1;
2850 type:=code.i shift (-12);
2851 if type<0 or type>5 then
2852 write(out,<:***String error:>,type)
2853 else
2854 begin
2855 case type+1 of
2856 begin
2857 <* 0 *> begin
2858 write(out,<: Empty string:>);
2859 list_string:=addr+2;
2860 end;
2861 <* 1 *> begin
2862 write(out,<: Variable :>);
2863 outchar(out,(code.i extract 12)+65);
2864 list_string:=addr+2;
2865 end;
2866 <* 2 *> begin
2867 write(out,<: Variable with interval :>);
2868 w_h(i,true);
2869 w_h(i+1,false);
2870 w_h(i+2,false);
2871 list_string:=addr+4;
2872 end;
2873 <* 3 *> begin
2874 write(out,<: Text with var.sub :>);
2875 list_string:=list_text(addr+2);
2876 end;
2877 <* 4 *> begin
2878 write(out,<: Text with var.sub and interval :>);
2879 w_h(i+1,false);
2880 w_h(i+2,false);
2881 list_string:=list_text(addr+4);
2882 end;
2883 <* 5 *> begin
2884 write(out,<: Constant text :>);
2885 list_string:=list_text(addr+2);
2886 end;
2887 end;
2888 end;
2889 end;
2890
2890 integer procedure list_text(addr);
2891 <*----------------------------------------------------------------*>
2892 <* Used by code-list. List text starting at addr *>
2893 <*----------------------------------------------------------------*>
2894 value addr;
2895 integer addr;
2896 begin
2897 integer array field iaf;
2898 integer field inx;
2899 integer i,j,ch;
2900
2900 inx:=addr+1;
2901 write(out,<:<10>:>,<<dddddd>,addr,<:+ Text:>,<< d>,
2902 code.inx shift (-12), code.inx extract 12);
2903 iaf:=inx;
2904 write(out,<: <60>:>);
2905 for i:=1 step 1 until (code.inx shift (-12))//2 do
2906 for j:=-16 step 8 until 0 do
2907 begin
2908 ch:=(code.iaf(i) shift j) extract 8;
2909 if ch<32 then
2910 begin
2911 if ch=0 then
2912 goto text_end;
2913 write(out,<:^:>);
2914 ch:=ch+64;
2915 end;
2916 if ch>127 then
2917 begin
2918 write(out,<:&:>);
2919 ch:=ch-63;
2920 end;
2921 outchar(out,ch);
2922 end;
2923 text_end:
2924 write(out,<:<62>:>);
2925 list_text:=addr+(code.inx shift (-12));
2926 end;
2927
2927 procedure w_addr(addr,text);
2928 integer field addr;
2929 string text;
2930 begin
2931 write(out,<:<10>:>,<<dddddd>,addr,<:+ :>,
2932 text,<< d>,code.addr);
2933 end;
2934
2934 procedure w_h(addr,var);
2935 boolean field addr;
2936 boolean var;
2937 begin
2938 write(out,<:<10>:>,<<dddddd>,addr,<:+ :>);
2939 if var then
2940 begin
2941 write(out,<:Variable :>);
2942 outchar(out,(code.addr extract 12)+65);
2943 end
2944 else
2945 write(out,<< d>,code.addr extract 12);
2946 end;
2947
2947 procedure code_list(op_addr,stop_addr);
2948 <*----------------------------------------------------------------*>
2949 <* List code formats from address op_addr *>
2950 <* until address stop_addr *>
2951 <*----------------------------------------------------------------*>
2952 value stop_addr;
2953 integer op_addr,stop_addr;
2954 begin
2955 integer op_code;
2956
2956 while op_addr<stop_addr do
2957 begin
2958 op:=op_addr-1;
2959 op_code:=code.op(1) shift (-12);
2960 if op_code<0 or op_code>24 then
2961 begin
2962 write(out,<:<10>:>,<<dddddd>,op_addr,
2963 <: ***error in op code :>,op_code);
2964 while op_code<0 or op_code>24 do
2965 begin
2966 op_addr:=op_addr+2;
2967 op:=op_addr-1;
2968 op_code:=code.op(1) shift (-12);
2969 write(out,<< d>,op_code);
2970 end;
2971 end;
2972 write(out,<:<10>:>,<<dddddd>,op_addr,<:::>,
2973 <<dddd >,code.op(1) extract 12,
2974 case op_code+1 of
2975 (<:New segment:>,
2976 <:Jump:>,
2977 <:Bool-exp:>,
2978 <:Red-bool-exp:>,
2979 <:Attention:>,
2980 <:Endattention:>,
2981 <:Include:>,
2982 <:Endinclude:>,
2983 <:At:>,
2984 <:Write:>,
2985 <:Nl:>,
2986 <:Read:>,
2987 <:Get:>,
2988 <:Let:>,
2989 <:Send:>,
2990 <:Execute:>,
2991 <:Direct:>,
2992 <:Exit:>,
2993 <:Output-on:>,
2994 <:Output-off:>,
2995 <:Echo-on:>,
2996 <:Echo-off:>,
2997 <:Menu:>,
2998 <:Erase:>,
2999 <:Convert:>));
3000 case op_code+1 of
3001 begin
3002 <* 0 *> begin
3003 op_addr:=(op_addr shift (-9)+1) shift 9;
3004 end;
3005 <* 1 *> begin
3006 op_addr:=op_addr+4;
3007 w_addr(op+3,<:addr::>);
3008 end;
3009 <* 2 *> begin
3010 op_addr:=if code.op(2)<code.op(3) then
3011 code.op(2)
3012 else
3013 code.op(3);
3014 w_addr(op+3,<:equal addr::>);
3015 w_addr(op+5,<:not equal addr::>);
3016 w_addr(op+7,<:right s addr::>);
3017 list_string(op+9);
3018 list_string(code.op(4));
3019 end;
3020 <* 3 *> begin
3021 op_addr:=if code.op(2)<code.op(3) then
3022 code.op(2)
3023 else
3024 code.op(3);
3025 w_addr(op+3,<:equal addr::>);
3026 w_addr(op+5,<:not equal addr::>);
3027 w_h(op+7,true);
3028 w_h(op+8,false);
3029 write(out,<: :>);
3030 for ii:=-16 step 8 until -24+8*(code.op(4) extract 12) do
3031 outchar(out,code.op(5) shift ii);
3032 end;
3033 <* 4 *> begin
3034 op_addr:=code.op(2);
3035 w_addr(op+3,<:next op.:>);
3036 w_addr(op+5,<:end att addr::>);
3037 w_h(op+7,true);
3038 list_string(op+9);
3039 end;
3040 <* 5 *> begin
3041 op_addr:=op_addr+2;
3042 end;
3043 <* 6 *> begin
3044 op_addr:=code.op(2);
3045 w_addr(op+3,<:next op.:>);
3046 w_addr(op+5,<:end inc addr::>);
3047 w_h(op+7,true);
3048 w_h(op+9,false);
3049 w_h(op+10,false);
3050 w_addr(op+11,<:pool s addr::>);
3051 w_addr(op+13,<:proc s addr::>);
3052 list_string(op+15);
3053 list_string(code.op(6));
3054 list_string(code.op(7));
3055 end;
3056 <* 7 *> begin
3057 op_addr:=op_addr+2;
3058 end;
3059 <* 8 *> begin
3060 op_addr:=op_addr+4;
3061 w_h(op+3,false);
3062 w_h(op+4,false);
3063 end;
3064 <* 9 *> begin
3065 op_addr:=code.op(2);
3066 w_addr(op+3,<:next op.:>);
3067 list_string(op+5);
3068 end;
3069 <* 10 *> begin
3070 op_addr:=op_addr+2;
3071 end;
3072 <* 11 *> begin
3073 op_addr:=op_addr+4;
3074 w_h(op+3,false);
3075 w_h(op+4,true);
3076 end;
3077 <* 12 *> begin
3078 op_addr:=op_addr+4;
3079 w_h(op+3,false);
3080 w_h(op+4,true);
3081 end;
3082 <* 13 *> begin
3083 op_addr:=code.op(2);
3084 w_addr(op+3,<:next op.:>);
3085 w_h(op+5,true);
3086 list_string(op+7);
3087 end;
3088 <* 14 *> begin
3089 op_addr:=code.op(2);
3090 w_addr(op+3,<:next op.:>);
3091 list_string(op+5);
3092 end;
3093 <* 15 *> begin
3094 op_addr:=code.op(2);
3095 w_addr(op+3,<:next op.:>);
3096 w_h(op+5,true);
3097 list_string(op+7);
3098 end;
3099 <* 16 *> begin
3100 op_addr:=op_addr+4;
3101 w_h(op+3,true);
3102 end;
3103 <* 17 *> begin
3104 op_addr:=list_string(op+3);
3105 end;
3106 <* 18 *> begin
3107 op_addr:=op_addr+2;
3108 end;
3109 <* 19 *> begin
3110 op_addr:=op_addr+2;
3111 end;
3112 <* 20 *> begin
3113 op_addr:=op_addr+2;
3114 end;
3115 <* 21 *> begin
3116 op_addr:=op_addr+2;
3117 end;
3118 <* 22 *> begin
3119 integer next_text,point_table,num_of_point,point;
3120 long array field laf;
3121 integer field i;
3122 integer pch;
3123
3123 op_addr:=op_addr+8;
3124 w_h(op+3,false);
3125 w_h(op+4,false);
3126 num_of_point:=code.op(2) extract 12;
3127 w_addr(op+5,<:first point:>);
3128 w_addr(op+7,<:menu text:>);
3129 next_text:=code.op(4);
3130 point_table:=code.op(3);
3131 code_list(op_addr,code.op(4));
3132 while next_text<>0 do
3133 begin
3134 write(out,<:<10>:>,<<dddddd>,next_text,<:+ Menu text:>);
3135 op:=next_text-1;
3136 next_text:=code.op(1);
3137 if next_text>0 then
3138 w_addr(op+1,<:next text:>);
3139 write(out,<< d>,code.op(2) shift (-12), code.op(2) extract 12);
3140 laf:=op+4;
3141 write(out,<:<10>--------Menu-text-start---<10>:>,code.laf,
3142 <:<10>--------Menu-text-end-----<10>:>);
3143 end;
3144 for op:=point_table-1 step 6 until
3145 (num_of_point-1)*6+point_table-1 do
3146 begin
3147 write(out,<:<10>:>,<<dddddd>,op+1,<:+ Point :>);
3148 pch:=code.op(1) shift (-12);
3149 if pch < 32 then
3150 begin
3151 pch:=pch+64;
3152 write(out,<:^:>);
3153 end
3154 else
3155 write(out,<: :>);
3156 outchar(out,pch);
3157 write(out,<: :>);
3158 for ii:=-11 step 1 until 0 do
3159 write(out,<<d>,(code.op(1) shift ii) extract 1);
3160 w_h(op+3,false);
3161 w_h(op+4,false);
3162 w_addr(op+5,<:action:>);
3163 end;
3164 op_addr:=point_table+6*num_of_point;
3165 end;
3166 <* 23 *> begin
3167 op_addr:=op_addr+2;
3168 end;
3169 <* 24 *> begin
3170 op_addr:=op_addr+4;
3171 w_h(op+3,true);
3172 end;
3173 end;
3174 end;
3175 end;
3176
3176
3176
3176 trap(traped);
3177 init_compiler;
3178 if list_source then
3179 write_headline;
3180 init_scan;
3181 open(source_text,4,source_file,0);
3182 if monitor(42,source_text,ii,tail)<>0 then
3183 init_error(3);
3184 if tail(9)<>0 then
3185 init_error(5);
3186 line_number:=0;
3187 get_new_line;
3188 next_token;
3189 while token_type<>t_end_file do
3190 begin
3191 action;
3192 if token_type<>t_end_file then
3193 begin
3194 syntax_error(22);
3195 while (token_type<t_select or token_type>t_echo)
3196 and token_type<>t_end_file do
3197 next_token;
3198 end;
3199 end;
3200 if false then
3201 traped: comp_error(alarmcause extract 24);
3202 stop:
3203 <* Insert exit at end *>
3204 s_line:=line_number;
3205 set_op(17,10);
3206 <* Default exit text *>
3207 code.op(2):=5 shift 12;
3208 code.op(3):=6 shift 12 + 5;
3209 code.op(4):= long <:exi:> shift (-24) extract 24;
3210 code.op(5):= long <:t :> shift (-24) extract 24;
3211 if show_code and make_code then
3212 begin
3213 write_headline;
3214 write(out,<:<10>Code list::>);
3215 code_list(0,next_free);
3216 end;
3217 if make_code and make_cmcl then
3218 begin
3219 real array field raf;
3220 open(cmcl_code,4,cmcl_file,0);
3221 monitor(42,cmcl_code,ii,tail);
3222 tail(1):=(next_free//512)+1;
3223 tail(6):=systime(7,0,rr);
3224 tail(9):=29 shift 12; <* Contents key 29 *>
3225 tail(10):=next_free; <* Size of code in hw's *>
3226 if monitor(44,cmcl_code,ii,tail)<>0 then
3227 begin
3228 for ii:=2,3,4,5,7,8 do
3229 tail(ii):=0;
3230 if monitor(40,cmcl_code,ii,tail)<>0 then
3231 init_error(6);
3232 end;
3233 for raf:=-1 step 512 until next_free-2 do
3234 begin
3235 outrec6(cmcl_code,512);
3236 tofrom(cmcl_code,code.raf,512);
3237 end;
3238 close(cmcl_code,true);
3239 end;
3240 write(out,<:<10>mcl end :>);
3241 if make_code then
3242 write(out,<: code:>,<< d>,next_free,<:<10>:>)
3243 else
3244 write(out,<: no code generated<10>:>);
3245 if warnings then
3246 errorbits:=1 shift 1;
3247 if -,make_code then
3248 errorbits:=3;
3249 end;
3250 end;\f
algol end 125
*o c
▶EOF◀