|
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: 94464 (0x17100)
Types: TextFile
Names: »mcltxt «
└─⟦9ccaf6601⟧ Bits:30008165 Bånd med SW8000 kildetekst/release værktøjer
└─⟦39138f30b⟧
└─⟦this⟧ »mcltxt «
begin
<**************************************************************>
<* MCL compiler source text for Terminal Access System *>
<* *>
<* Compiles MCL source text to cmcl format code *>
<* Produce all code in core before writing it to file *>
<* *>
<* Henning Godske 870506 *>
<* A/S Regnecentralen *>
<* *>
<* Compiler call: <result>=algol <source> connect.no *>
<**************************************************************>
<**************************************************************>
<* Revision history *>
<* *>
<* 87.05.06 MCL compiler release 1.0 *>
<**************************************************************>
<*--------------------------------------*>
<* Constans used global *>
<*--------------------------------------*>
integer max_var, <* Max. numbers of var's *>
max_string, <* Max. numbers of chars. in text *>
max_code, <* Max. code address *>
keywords; <* Number of keywords *>
array pn(1:2); <* Program name *>
integer i; <* work *>
<* Reserve 50 segments for algol to run in, *>
<* use rest for code array *>
max_code:=((system(2,i,pn)//512)-50)*512;
keywords:=40;
max_var:=25;
max_string:=80;
begin
<*---------------------------*>
<* Globale scanner variables *>
<*---------------------------*>
integer array newintable(0:255);
integer item;
integer last_item;
integer token_type,
line_number,
token_number_val,
token_string_length,
token_number;
boolean token_var_sub;
long array item_val(0:200);
integer array item_kind(0:200);
long array token_text(1:200);
long array symbol_text(1:keywords);
integer array symbol_val(1:keywords);
zone source_text(256,2,stderror);
<*----------------------------*>
<* Globale compiler variables *>
<*----------------------------*>
boolean list_source, <* list.yes *>
show_warning, <* warning.yes *>
show_test, <* test.yes *>
show_code, <* code.yes *>
use_note, <* note.yes *>
make_code, <* Produce code *>
make_cmcl, <* make result file *>
warnings;
integer array tail(1:10);
real array cmcl_file,source_file(1:2);
integer next_free, <* Next free address in code *>
while_start, <* Current while block start *>
att_start, <* Current att or inc block start *>
s_line, <* Source line number *>
ii; <* work *>
real rr; <* work *>
boolean in_attention,
in_include;
integer array field op;
boolean array code(0:max_code); <* Code array with index in hw *>
zone cmcl_code(256,2,stderror);
<*------------------------------------------------*>
<* Token constants used global. Set in init_scan *>
<*------------------------------------------------*>
integer t_end_file,
t_case,
t_otherwise,
t_endselect,
t_else,
t_endif,
t_point,
t_text,
t_endmenu,
t_endwhile,
t_endattention,
t_endinclude,
t_select,
t_while,
t_menu,
t_attention,
t_include,
t_at,
t_write,
t_nl,
t_erase,
t_read,
t_get,
t_let,
t_send,
t_if,
t_execute,
t_note,
t_direct,
t_loop,
t_exit,
t_output,
t_convert,
t_echo,
t_of,
t_do,
t_then,
t_equal,
t_not,
t_on,
t_off,
t_int_start,
t_int_end,
t_unknown,
t_number,
t_string,
t_errstring,
t_var,
t_and,
t_or;
procedure init_error(nr);
<*----------------------------------------------------------------*>
<* Write initial error and stop *>
<*----------------------------------------------------------------*>
integer nr;
begin
integer i;
i:=1;
write(out,<:***:>,string pn(increase(i)));
if nr<1 or nr>7 then
nr:=8; <* Max. init error number used + 1 *>
write(out,<: :>,case nr of
(<:No source file specified:>,
<:Parameter:>,
<:Source file not found:>,
<:Process too small:>,
<:Source file not a text file:>,
<:Can't create result file:>,
<:Can't use result file:>,
<:Undefined error:>),<:<10>:>);
make_code:=false;
goto stop;
end;
procedure init_compiler;
<*----------------------------------------------------------------*>
<* Read FP parameters and init. global variables *>
<*----------------------------------------------------------------*>
begin
real array ra(1:2);
integer sy,i,j;
trapmode:=1 shift 10;
errorbits:=0;
warnings:=false;
list_source:=use_note:=false;
show_warning:=make_cmcl:=true;
show_code:=show_test:=false;
zero_code; <* nulstil kode område *>
make_code:=true;
next_free:=while_start:=0;
in_attention:=in_include:=false;
if max_code<512 then
init_error(4);
if (system(4,1,ra) shift (-12))=6 then
begin
system(4,0,ra);
make_cmcl:=true;
for j:=1,2 do
cmcl_file(j):=ra(j);
i:=2;
end
else
begin
make_cmcl:=false;
i:=1;
end;
if system(4,i,ra)<>(4 shift 12 + 10) then
<* error in source specification *>
init_error(1);
for j:=1,2 do
source_file(j):=ra(j);
i:=i+1;
sy:=system(4,i,ra);
while sy<>0 do
begin
if ra(1) = real <:test:> then
begin
i:=i+1;
if system(4,i,ra)<>(8 shift 12 + 10) then
<* error in yes/no spec. *>
init_error(2);
if ra(1) = real <:yes:> then
show_test:=true
else
begin
if ra(1) = real <:no:> then
show_test:=false
else
init_error(2);
end;
end;
if ra(1) = real <:code:> then
begin
i:=i+1;
if system(4,i,ra)<>(8 shift 12 + 10) then
<* error in yes/no spec. *>
init_error(2);
if ra(1) = real <:yes:> then
show_code:=true
else
begin
if ra(1) = real <:no:> then
show_code:=false
else
init_error(2);
end;
end;
if ra(1) = real <:list:> then
begin
i:=i+1;
if system(4,i,ra)<>(8 shift 12 + 10) then
<* error in yes/no spec. *>
init_error(2);
if ra(1) = real <:yes:> then
list_source:=true
else
begin
if ra(1) = real <:no:> then
list_source:=false
else
init_error(2);
end;
end;
if ra(1) = real <:note:> then
begin
i:=i+1;
if system(4,i,ra)<>(8 shift 12 + 10) then
<* error in yes/no spec. *>
init_error(2);
if ra(1) = real <:yes:> then
use_note:=true
else
begin
if ra(1) = real <:no:> then
use_note:=false
else
init_error(2);
end;
end;
if ra(1) = real <:warni:> add 'n' then
begin
i:=i+1;
if system(4,i,ra)<>(8 shift 12 + 10) then
<* error in yes/no spec. *>
init_error(2);
if ra(1) = real <:yes:> then
show_warning:=true
else
begin
if ra(1) = real <:no:> then
show_warning:=false
else
init_error(2);
end;
end;
i:=i+1;
sy:=system(4,i,ra);
end;
end;
procedure init_scan;
<*----------------------------------------------------------------*>
<* Init. intable and keyword table used by scanner *>
<*----------------------------------------------------------------*>
begin
integer i;
item_val(0):=0;
item_kind(0):=0;
<* Init intable *>
<* Kind: *>
<* 1 : Illegal number *>
<* 2 : Number *>
<* 3 - *>
<* 4 - *>
<* 5 - *>
<* 6 : Keyword *>
<* 7 : Delimiter *>
<* 8 : End line (EM, NL, FF) *>
<* 9 : Text start char: < *>
<* 10 : Text stop char: > *>
<* 11 : Char. in text or comment (--) *>
<* 12 : & or ^ or _ in text *>
<* 13 : Alfa in text or comment *>
<* 14 : Interval start char: ( *>
<* 15 : Interval stop char: ) *>
<* 16 : Symbol ! *>
<* 17 : Synbol = *>
<* 18 : Illegal character *>
<* *>
for i:=1 step 1 until 256 do
newintable(i-1):=
(case i of <* Kind *>
( 0, <* nul *>
18, <* soh *>
18, <* stx *>
18, <* etx *>
18, <* eot *>
18, <* enq *>
18, <* ack *>
18, <* bel *>
18, <* bs *>
18, <* ht *>
8, <* nl *>
18, <* vt *>
8, <* ff *>
0, <* cr *>
18, <* so *>
18, <* si *>
18, <* dle *>
18, <* dc1 *>
18, <* dc2 *>
18, <* dc3 *>
18, <* dc4 *>
18, <* nak *>
18, <* syn *>
18, <* etb *>
18, <* can *>
8, <* em *>
18, <* sub *>
18, <* esc *>
18, <* fs *>
18, <* gs *>
18, <* rs *>
18, <* us *>
7, <* *>
16, <* ! *>
18, <* " *>
18, <* # *>
18, <* $ *>
18, <* % *>
18, <* & *>
18, <* ' *>
14, <* ( *>
15, <* ) *>
18, <* * *>
18, <* + *>
18, <* , *>
1, <* - *>
18, <* . *>
18, <* / *>
2, <* 0 *>
2, <* 1 *>
2, <* 2 *>
2, <* 3 *>
2, <* 4 *>
2, <* 5 *>
2, <* 6 *>
2, <* 7 *>
2, <* 8 *>
2, <* 9 *>
18, <* : *>
18, <* ; *>
1, <* < *>
17, <* = *>
10, <* > *>
18, <* ? *>
18, <* @ *>
6, <* A *>
6, <* B *>
6, <* C *>
6, <* D *>
6, <* E *>
6, <* F *>
6, <* G *>
6, <* H *>
6, <* I *>
6, <* J *>
6, <* K *>
6, <* L *>
6, <* M *>
6, <* N *>
6, <* O *>
6, <* P *>
6, <* Q *>
6, <* R *>
6, <* S *>
6, <* T *>
6, <* U *>
6, <* V *>
6, <* W *>
6, <* X *>
6, <* Y *>
6, <* Z *>
6, <* Æ *>
6, <* Ø *>
6, <* Å *>
18, <* ^ *>
18, <* _ *>
18, <* ` *>
6, <* a *>
6, <* b *>
6, <* c *>
6, <* d *>
6, <* e *>
6, <* f *>
6, <* g *>
6, <* h *>
6, <* i *>
6, <* j *>
6, <* k *>
6, <* l *>
6, <* m *>
6, <* n *>
6, <* o *>
6, <* p *>
6, <* q *>
6, <* r *>
6, <* s *>
6, <* t *>
6, <* u *>
6, <* v *>
6, <* w *>
6, <* x *>
6, <* y *>
6, <* z *>
6, <* æ *>
6, <* ø *>
6, <* å *>
18, <* ü *>
18, <* del *>
<*-------------------*>
0, <* nul *>
0, <* soh *>
0, <* stx *>
0, <* etx *>
0, <* eot *>
0, <* enq *>
0, <* ack *>
0, <* bel *>
0, <* bs *>
0, <* ht *>
8, <* nl *>
0, <* vt *>
8, <* ff *>
0, <* cr *>
0, <* so *>
0, <* si *>
0, <* dle *>
0, <* dc1 *>
0, <* dc2 *>
0, <* dc3 *>
0, <* dc4 *>
0, <* nak *>
0, <* syn *>
0, <* etb *>
0, <* can *>
8, <* em *>
0, <* sub *>
0, <* esc *>
0, <* fs *>
0, <* gs *>
0, <* rs *>
0, <* us *>
11, <* *>
11, <* ! *>
11, <* " *>
11, <* # *>
11, <* $ *>
11, <* % *>
12, <* & *>
11, <* ' *>
11, <* ( *>
11, <* ) *>
11, <* * *>
11, <* + *>
11, <* , *>
11, <* - *>
11, <* . *>
11, <* / *>
11, <* 0 *>
11, <* 1 *>
11, <* 2 *>
11, <* 3 *>
11, <* 4 *>
11, <* 5 *>
11, <* 6 *>
11, <* 7 *>
11, <* 8 *>
11, <* 9 *>
11, <* : *>
11, <* ; *>
9, <* < *>
11, <* = *>
1, <* > *>
11, <* ? *>
11, <* @ *>
13, <* A *>
13, <* B *>
13, <* C *>
13, <* D *>
13, <* E *>
13, <* F *>
13, <* G *>
13, <* H *>
13, <* I *>
13, <* J *>
13, <* K *>
13, <* L *>
13, <* M *>
13, <* N *>
13, <* O *>
13, <* P *>
13, <* Q *>
13, <* R *>
13, <* S *>
13, <* T *>
13, <* U *>
13, <* V *>
13, <* W *>
13, <* X *>
13, <* Y *>
13, <* Z *>
13, <* Æ *>
13, <* Ø *>
13, <* Å *>
12, <* ^ *>
8, <* _ *>
11, <* ` *>
13, <* a *>
13, <* b *>
13, <* c *>
13, <* d *>
13, <* e *>
13, <* f *>
13, <* g *>
13, <* h *>
13, <* i *>
13, <* j *>
13, <* k *>
13, <* l *>
13, <* m *>
13, <* n *>
13, <* o *>
13, <* p *>
13, <* q *>
13, <* r *>
13, <* s *>
13, <* t *>
13, <* u *>
13, <* v *>
13, <* w *>
13, <* x *>
13, <* y *>
13, <* z *>
13, <* æ *>
13, <* ø *>
13, <* å *>
11, <* ü *>
0 ))<* del *>
shift 12 +
(case i of <* Value *>
( 0, <* nul *>
0, <* soh *>
0, <* stx *>
0, <* etx *>
0, <* eot *>
0, <* enq *>
0, <* ack *>
0, <* bel *>
0, <* bs *>
0, <* ht *>
10, <* nl *>
0, <* vt *>
12, <* ff *>
0, <* cr *>
0, <* so *>
0, <* si *>
0, <* dle *>
0, <* dc1 *>
0, <* dc2 *>
0, <* dc3 *>
0, <* dc4 *>
0, <* nak *>
0, <* syn *>
0, <* etb *>
0, <* can *>
25, <* em *>
0, <* sub *>
0, <* esc *>
0, <* fs *>
0, <* gs *>
0, <* rs *>
0, <* us *>
32, <* *>
33, <* ! *>
34, <* " *>
35, <* # *>
36, <* $ *>
37, <* % *>
38, <* & *>
39, <* ' *>
40, <* ( *>
41, <* ) *>
42, <* * *>
43, <* + *>
44, <* , *>
128, <* - *>
46, <* . *>
47, <* / *>
48, <* 0 *>
49, <* 1 *>
50, <* 2 *>
51, <* 3 *>
52, <* 4 *>
53, <* 5 *>
54, <* 6 *>
55, <* 7 *>
56, <* 8 *>
57, <* 9 *>
58, <* : *>
59, <* ; *>
128, <* < *>
61, <* = *>
62, <* > *>
63, <* ? *>
64, <* @ *>
65, <* A *>
66, <* B *>
67, <* C *>
68, <* D *>
69, <* E *>
70, <* F *>
71, <* G *>
72, <* H *>
73, <* I *>
74, <* J *>
75, <* K *>
76, <* L *>
77, <* M *>
78, <* N *>
79, <* O *>
80, <* P *>
81, <* Q *>
82, <* R *>
83, <* S *>
84, <* T *>
85, <* U *>
86, <* V *>
87, <* W *>
88, <* X *>
89, <* Y *>
90, <* Z *>
91, <* Æ *>
92, <* Ø *>
93, <* Å *>
94, <* ^ *>
95, <* _ *>
96, <* ` *>
65, <* a *>
66, <* b *>
67, <* c *>
68, <* d *>
69, <* e *>
70, <* f *>
71, <* g *>
72, <* h *>
73, <* i *>
74, <* j *>
75, <* k *>
76, <* l *>
77, <* m *>
78, <* n *>
79, <* o *>
80, <* p *>
81, <* q *>
82, <* r *>
83, <* s *>
84, <* t *>
85, <* u *>
86, <* v *>
87, <* w *>
88, <* x *>
89, <* y *>
90, <* z *>
91, <* æ *>
92, <* ø *>
93, <* å *>
126, <* ü *>
0, <* del *>
<*-------------------*>
0, <* nul *>
0, <* soh *>
0, <* stx *>
0, <* etx *>
0, <* eot *>
0, <* enq *>
0, <* ack *>
0, <* bel *>
0, <* bs *>
0, <* ht *>
10, <* nl *>
0, <* vt *>
12, <* ff *>
0, <* cr *>
0, <* so *>
0, <* si *>
0, <* dle *>
0, <* dc1 *>
0, <* dc2 *>
0, <* dc3 *>
0, <* dc4 *>
0, <* nak *>
0, <* syn *>
0, <* etb *>
0, <* can *>
25, <* em *>
0, <* sub *>
0, <* esc *>
0, <* fs *>
0, <* gs *>
0, <* rs *>
0, <* us *>
32, <* *>
33, <* ! *>
34, <* " *>
35, <* # *>
36, <* $ *>
37, <* % *>
38, <* & *>
39, <* ' *>
40, <* ( *>
41, <* ) *>
42, <* * *>
43, <* + *>
44, <* , *>
45, <* - *>
46, <* . *>
47, <* / *>
48, <* 0 *>
49, <* 1 *>
50, <* 2 *>
51, <* 3 *>
52, <* 4 *>
53, <* 5 *>
54, <* 6 *>
55, <* 7 *>
56, <* 8 *>
57, <* 9 *>
58, <* : *>
59, <* ; *>
60, <* < *>
61, <* = *>
0, <* > *>
63, <* ? *>
64, <* @ *>
65, <* A *>
66, <* B *>
67, <* C *>
68, <* D *>
69, <* E *>
70, <* F *>
71, <* G *>
72, <* H *>
73, <* I *>
74, <* J *>
75, <* K *>
76, <* L *>
77, <* M *>
78, <* N *>
79, <* O *>
80, <* P *>
81, <* Q *>
82, <* R *>
83, <* S *>
84, <* T *>
85, <* U *>
86, <* V *>
87, <* W *>
88, <* X *>
89, <* Y *>
90, <* Z *>
91, <* Æ *>
92, <* Ø *>
93, <* Å *>
94, <* ^ *>
95, <* _ *>
96, <* ` *>
97, <* a *>
98, <* b *>
99, <* c *>
100, <* d *>
101, <* e *>
102, <* f *>
103, <* g *>
104, <* h *>
105, <* i *>
106, <* j *>
107, <* k *>
108, <* l *>
109, <* m *>
110, <* n *>
111, <* o *>
112, <* p *>
113, <* q *>
114, <* r *>
115, <* s *>
116, <* t *>
117, <* u *>
118, <* v *>
119, <* w *>
120, <* x *>
121, <* y *>
122, <* z *>
123, <* æ *>
124, <* ø *>
125, <* å *>
126, <* ü *>
0 ))<* del *>
extract 12;
intable(newintable);
t_end_file :=00;
t_case :=01;
t_otherwise :=02;
t_endselect :=03;
t_else :=04;
t_endif :=05;
t_point :=06;
t_text :=07;
t_endmenu :=08;
t_endwhile :=09;
t_endattention :=10;
t_endinclude :=11;
t_select :=12;
t_while :=13;
t_menu :=14;
t_attention :=15;
t_include :=16;
t_at :=17;
t_write :=18;
t_nl :=19;
t_erase :=20;
t_read :=21;
t_get :=22;
t_let :=23;
t_send :=24;
t_if :=25;
t_execute :=26;
t_note :=27;
t_direct :=28;
t_loop :=29;
t_exit :=30;
t_output :=31;
t_convert :=32;
t_echo :=33;
t_of :=34;
t_do :=35;
t_then :=36;
t_equal :=37;
t_not :=38;
t_on :=39;
t_off :=40;
t_int_start :=41;
t_int_end :=42;
t_unknown :=43;
t_number :=44;
t_string :=45;
t_errstring :=46;
t_var :=47;
t_and :=48;
t_or :=49;
<* Keywords for mcl *>
<* Bemærk alfabetisk opstilling *>
for i:=1 step 1 until keywords do
begin
symbol_text(i):=
case i of
( long <:AND:>,
long <:AT:>,
long <:ATTEN:> add 'T',
long <:CASE:>,
long <:CONVE:> add 'R',
long <:DIREC:> add 'T',
long <:DO:>,
long <:ECHO:>,
long <:ELSE:>,
long <:ENDAT:> add 'T',
long <:ENDIF:>,
long <:ENDIN:> add 'C',
long <:ENDME:> add 'N',
long <:ENDSE:> add 'L',
long <:ENDWH:> add 'I',
long <:ERASE:>,
long <:EXECU:> add 'T',
long <:EXIT:>,
long <:GET:>,
long <:IF:>,
long <:INCLU:> add 'D',
long <:LET:>,
long <:LOOP:>,
long <:MENU:>,
long <:NL:>,
long <:NOTE:>,
long <:OF:>,
long <:OFF:>,
long <:ON:>,
long <:OR:>,
long <:OTHER:> add 'W',
long <:OUTPU:> add 'T',
long <:POINT:>,
long <:READ:>,
long <:SELEC:> add 'T',
long <:SEND:>,
long <:TEXT:>,
long <:THEN:>,
long <:WHILE:>,
long <:WRITE:> );
<* Token values for keywords *>
symbol_val(i):= case i of
(t_and, t_at, t_attention, t_case, t_convert, t_direct,
t_do, t_echo, t_else, t_endattention,
t_endif, t_endinclude, t_endmenu,
t_endselect, t_endwhile, t_erase,
t_execute, t_exit, t_get, t_if,
t_include, t_let, t_loop, t_menu,
t_nl, t_note, t_of, t_off, t_on, t_or,
t_otherwise, t_output, t_point,
t_read, t_select, t_send, t_text,
t_then, t_while, t_write);
end;
end;
procedure warning(nr);
<*----------------------------------------------------------------*>
<* Write warning on current output *>
<*----------------------------------------------------------------*>
value nr;
integer nr;
begin
if show_warning then
begin
if list_source then
write(out,<:<10>***warning :>)
else
write(out,<:<10>:>,<<dddd >,line_number,<:: warning :>);
if nr<1 or nr>4 then
nr:=5; <* Max. warning number used + 1 *>
write(out,<< dd>,token_number,<:. :>,case nr of
(<:no link:>,
<:too many menu lines:>,
<:illegal character:>,
<:constant string with interval:>,
<:undefined warning:>));
end;
warnings:=true;
end;
procedure mcl_error(nr);
<*----------------------------------------------------------------*>
<* Write error on current output *>
<*----------------------------------------------------------------*>
value nr;
integer nr;
begin
if list_source then
write(out,<:<10>***error :>)
else
write(out,<:<10>:>,<<dddd >,line_number,<:: error :>);
if nr<1 or nr>12 then
nr:=12; <* Max. error number used + 1 *>
write(out,<< dd>,token_number,<:. :>,case nr of
(<:no selectable menu text lines:>,
<:string size:>,
<:non constant string:>,
<:empty string:>,
<:illegal number:>,
<:column > 79:>,
<:line > 24:>,
<:line = 0:>,
<:already in attention or include:>,
<:point not unique:>,
<:source line too long:>,
<:undefined error:>));
make_code:=false;
end;
procedure comp_error(nr);
<*----------------------------------------------------------------*>
<* Called when error in this program is detected *>
<* Write error and goto stop *>
<*----------------------------------------------------------------*>
integer nr;
begin
ii:=1;
write(out,<:<10>***internal :>,nr,<:<10>:>);
goto stop;
end;
procedure syntax_error(nr);
<*----------------------------------------------------------------*>
<* writes syntax error on current output *>
<* signals that no usefull code is produced *>
<*----------------------------------------------------------------*>
value nr;
integer nr;
begin
if list_source then
write(out,<< dddd>,<:<10>***syntax :>)
else
write(out,<:<10>:>,<<dddd >,line_number,<:: syntax :>);
if nr<1 or nr>23 then
nr:=24; <* Max. error number used + 1 *>
write(out,<< dd>,token_number,<:. :>,case nr of
(<:error in string:>,
<:unknown keyword:>,
<:number missing:>,
<:interval error:>,
<:) missing:>,
<:variabel missing:>,
<:OF missing:>,
<:CASE expected:>,
<:ENDSELECT expected:>,
<:= missing:>,
<:DO missing:>,
<:ENDWHILE expected:>,
<:POINT expected:>,
<:too many points:>,
<:ENDMENU expected:>,
<:ENDATTENTION expected:>,
<:ENDINCLUDE expected:>,
<:sentence expected:>,
<:THEN missing:>,
<:ENDIF expected:>,
<:ON or OFF missing:>,
<:structure:>,
<:illegal variable:>,
<:undefined error:>));
make_code:=false;
end;
procedure syntax_scan(nr);
<*----------------------------------------------------------------*>
<* write syntax error and scans to next sentence *>
<*----------------------------------------------------------------*>
value nr;
integer nr;
begin
syntax_error(nr);
while token_type>t_echo do
begin
next_token;
if token_type=t_errstring then
syntax_error(1);
if token_type=t_unknown then
syntax_error(2);
end;
end;
procedure write_headline;
<*----------------------------------------------------------------*>
<* Write form-feed and headline on current output *>
<*----------------------------------------------------------------*>
begin
integer i;
real array on(1:2);
system(6,i,on);
i:=1;
write(out,<:<12><10>:>,string on(increase(i)),<: :>);
i:=1;
write(out,<:mcl d.:>,<<zddddd>,systime(5,0,rr),<:.:>,rr);
i:=1;
write(out,<: source file: :>,string source_file(increase(i)),<:<10>:>);
end;
procedure get_new_line;
<*----------------------------------------------------------------*>
<* Read next line from source and list this line *>
<* on current output if LIST.YES *>
<*----------------------------------------------------------------*>
begin
integer ch;
tableindex:=0;
last_item:=read_all(source_text,item_val,item_kind,1);
while item_val(last_item)=95 do
begin
item_kind(last_item):=12;
if table_index=128 then
begin
last_item:=last_item+1;
read_char(source_text,ch);
item_kind(last_item):=13;
item_val(last_item):=ch;
table_index:=128;
end;
last_item:=read_all(source_text,item_val,item_kind,last_item+1)+last_item;
end;
item:=0;
token_number:=0;
if -,(item_kind(1)=8 and item_val(1)=25) then
begin
line_number:=line_number+1;
if list_source then
begin
<* Write line *>
long array field key_word;
integer i;
write(out,<:<10>:>,<<dddd>,line_number,<: : :>);
for i:=1 step 1 until abs last_item do
if (item_kind(i)>8) or (item_kind(i)=7) then
begin
if (item_kind(i)=12) and
(item_val(i)<>95) and
(item_val(i-1)<>95) and
(item_kind(i+1)=13) and
(item_val(i+1)>96) then
item_val(i+1):=item_val(i+1)-32;
outchar(out,item_val(i) extract 24);
end
else
if item_kind(i)=6 then
begin
key_word:=(i-1)*4;
write(out,item_val.key_word);
while item_kind(i+1)=6 do
i:=i+1;
end
else
if item_kind(i)<3 then
write(out,<<d>,item_val(i))
else
if (item_kind(i)=8) and item_val(i)=12 then
write_headline;
end;
if last_item<0 then
begin
while readchar(source_text,ch)<>8 do;
last_item:=-last_item;
end;
end;
end;
procedure next_item;
<*----------------------------------------------------------------*>
<* Get next item from line read from source *>
<*----------------------------------------------------------------*>
begin
if item=0 then
item:=1
else
if item_kind(item)=8 then
begin
if item_val(item)<>25 then
begin
get_new_line;
item:=1;
end;
end
else
if item=last_item then
begin
item_kind(item):=8;
item_val(item):=10;
mcl_error(11);
end
else
item:=item+1;
end;
procedure next_token;
<*----------------------------------------------------------------*>
<* Get next token value evaluated from *>
<* reading one or more items *>
<*----------------------------------------------------------------*>
begin
integer index,low_index,high_index,
i,text_ch,ch;
next_token_start:
next_item;
case item_kind(item) of
begin
<* 1 Illegal number *>
comp_error(1);
<* 2 Number *>
begin
token_number_val:=item_val(item);
token_type:=t_number;
end;
<* 3 *>
comp_error(2);
<* 4 *>
comp_error(3);
<* 5 *>
comp_error(4);
<* 6 keyword *>
begin
if (item_val(item) shift 8)=0 then
begin <* 1 char. then VARIABLE *>
token_type:=t_var;
token_number_val:=(item_val(item) shift (-40))-65;
if token_number_val>31 then
token_number_val:=token_number_val-32;
if token_number_val>max_var then
syntax_error(23);
end
else
begin <* Keyword *>
index:=keywords//2;
low_index:=1;
high_index:=keywords;
<* Use binary search to find value *>
while item_val(item)<>symbol_text(index) do
begin
if low_index>=high_index then
begin
<* error keyword not found *>
token_type:=t_unknown;
goto key_word_end;
end;
if item_val(item) < symbol_text(index) then
high_index:=index-1
else
low_index:=index+1;
index:=(high_index-low_index)//2+low_index;
if index<1 or index>keywords then
comp_error(5);
end;
token_type:=symbol_val(index);
key_word_end:
while item_kind(item+1)=6 do
next_item;
end;
end;
<* 7 Delimiter *>
goto next_token_start;
<* 8 End line *>
if item_val(item)=25 then
token_type:=t_end_file
else
goto next_token_start;
<* 9 Text start < *>
begin
boolean string_error;
string_error:=false;
<* init token text *>
for i:=1 step 1 until 15 do
token_text(i):=0;
token_var_sub:=false;
next_item;
text_ch:=1;
if (item_kind(item)<9) or (item_kind(item)>13) then
begin
string_error:=true;
goto string_end;
end;
while (item_kind(item)<>10) do
begin
if (item_kind(item)<9) or (item_kind(item)>13) then
begin
string_error:=true;
goto string_end;
end;
if item_kind(item)=12 then
begin
if item_val(item)=94 then
begin
next_item;
ch:=item_val(item) extract 5;
if (item_kind(item)<11) or
(item_kind(item)>13) or
(ch=0) then
begin
string_error:=true;
goto string_end;
end;
end
else
if item_val(item)=95 then
begin
next_item;
ch:=item_val(item);
if item_kind(item)=8 then
begin
string_error:=true;
goto string_end;
end;
if item_kind(item)=10 then
table_index:=128;
end
else
begin
next_item;
if item_kind(item)<>13 then
begin
string_error:=true;
ch:=0;
end
else
begin
ch:=item_val(item)+63;
if ch>159 then
ch:=ch-32;
token_var_sub:=true;
if ch-128>max_var then
syntax_error(23);
end;
end;
end
else
ch:=item_val(item);
token_text((text_ch-1)//6+1):=
token_text((text_ch-1)//6+1) shift 8 + ch extract 8;
if text_ch<82 then
text_ch:=text_ch+1;
next_item;
end; <* Insert in string *>
string_end:
token_string_length:=text_ch-1;
i:=token_string_length mod 6;
if i<>0 then
token_text((token_string_length)//6+1):=
token_text((token_string_length)//6+1) shift ((6-i)*8);
if string_error then
token_type:=t_errstring
else
token_type:=t_string;
end;
<* 10 Illegal char. > *>
begin
warning(3);
goto next_token_start;
end;
<* 11 Comment -- *>
begin
next_item;
if item_kind(item)<>11 then
warning(3);
next_item;
while (item_kind(item)<>8) do
next_item;
if item_val(item)=25 then
begin
token_type:=t_end_file;
goto next_token_end;
end;
goto next_token_start;
end;
<* 12 & in text *>
comp_error(7);
<* 13 Alfa in text *>
comp_error(8);
<* 14 Int start ( *>
token_type:=t_int_start;
<* 15 Int stop ) *>
token_type:=t_int_end;
<* 16 != *>
begin
next_item;
if item_kind(item)<>17 then
syntax_error(10);
token_type:=t_not;
end;
<* 17 = *>
token_type:=t_equal;
<* 18 Illegal char. *>
begin
warning(3);
goto next_token_start;
end;
end;
next_token_end:
token_number:=token_number+1;
end; <* Next token *>
procedure zero_code;
<*----------------------------------------------------------------*>
<* insert zero's in hole code area *>
<*----------------------------------------------------------------*>
begin
long array field laf;
integer i;
laf:=0;
code(0):=false;
for i:=1 step 1 until max_code//4 do
code.laf(i):=0;
end;
integer procedure set_op(opcode_nr,code_length);
<*----------------------------------------------------------------*>
<* Set OP to current opcode start, *>
<* insert opcode nr and s_line, code_length is number *>
<* of half word that shall be free in the same segment. *>
<* If it's not posible in current segment start in *>
<* next segment *>
<*----------------------------------------------------------------*>
value opcode_nr,code_length;
integer opcode_nr,code_length;
begin
integer length_to_limit;
length_to_limit:=512-(next_free mod 512);
if length_to_limit<code_length then
op:=next_free+length_to_limit-1
else
op:=next_free-1;
next_free:=op+code_length+1;
if next_free>=max_code then
init_error(4);
code.op(1):=opcode_nr shift 12 +(s_line extract 12);
set_op:=next_free;
end;
integer procedure find_string_address(string_length);
<*----------------------------------------------------------------*>
<* Find room to insert string_length hw's in the same *>
<* segment starting at next_free *>
<*----------------------------------------------------------------*>
value string_length;
integer string_length;
begin
integer length_to_limit,i;
length_to_limit:=512-(next_free mod 512);
if string_length>length_to_limit then
i:=next_free+length_to_limit
else
i:=next_free;
find_string_address:=i;
end;
procedure insert_jump(addr,jump);
<*----------------------------------------------------------------*>
<* Insert a jump op-code *>
<*----------------------------------------------------------------*>
value jump;
integer field addr;
integer jump;
begin
integer field next_addr;
while addr<>0 do
begin
next_addr:=code.addr;
code.addr:=jump;
addr:=next_addr;
end;
end;
procedure make_bool(f_addr,t_addr);
<*----------------------------------------------------------------*>
<* Producer kode for bool-exp *>
<* returner peger til false og true *>
<* adresse felterne i koden *>
<*----------------------------------------------------------------*>
integer field f_addr,t_addr;
begin
integer array left_string,right_string (1:max_string//3+5);
boolean equal;
if -,make_string(left_string) then
begin
syntax_scan(1);
goto end_bool;
end;
equal:=false;
if token_type=t_equal then
equal:=true
else
if token_type<>t_not then
syntax_error(10);
next_token;
if -,make_string(right_string) then
begin
syntax_scan(1);
goto end_bool;
end;
<* make bool-exp *>
if (left_string(2) shift (-12)=1) and
(right_string(2) shift (-12)=5) and
(right_string(3) extract 12 <=3) then
begin
set_op(3,10);
code.op(4):=(left_string(2) extract 12) shift 12 +
(right_string(3) extract 12);
code.op(5):=right_string(4);
end
else
if (right_string(2) shift (-12)=1) and
(left_string(2) shift (-12)=5) and
(left_string(3) extract 12 <=3) then
begin
set_op(3,10);
code.op(4):=(right_string(2) extract 12) shift 12 +
(left_string(3) extract 12);
code.op(5):=left_string(4);
end
else
if right_string(2) shift (-12)=0 and
left_string(2) shift (-12)=1 then
begin
set_op(3,10);
code.op(4):=left_string(2) shift 12;
code.op(5):=0;
end
else
if left_string(2) shift (-12)=0 and
right_string(2) shift (-12)=1 then
begin
set_op(3,10);
code.op(4):=right_string(2) shift 12;
code.op(5):=0;
end
else
begin
set_op(2,8+left_string(1));
insert_string(left_string,op+9);
code.op(4):=find_string_address(right_string(1));
insert_string(right_string,code.op(4));
end;
if equal then
begin
f_addr:=op+6;
t_addr:=op+4; <* true jump *>
end
else
begin
t_addr:=op+6; <* false jump *>
f_addr:=op+4;
end;
end_bool:
end;
procedure make_bool_exp(end_token_type,error_nr,f_addr,t_addr);
<*----------------------------------------------------------------*>
<* Producer kode for bool-exp ink. AND / OR *>
<* returner peger til false og true *>
<* adresse felterne i koden *>
<*----------------------------------------------------------------*>
integer end_token_type,error_nr;
integer field f_addr,t_addr;
begin
integer prev_addr;
make_bool(f_addr,t_addr);
while token_type=t_and or token_type=t_or do
begin
if token_type=t_and then
begin
insert_jump(t_addr,next_free);
prev_addr:=f_addr;
next_token;
make_bool(f_addr,t_addr);
code.f_addr:=prev_addr;
end
else
if token_type=t_or then
begin
insert_jump(f_addr,next_free);
prev_addr:=t_addr;
next_token;
make_bool(f_addr,t_addr);
code.t_addr:=prev_addr;
end
end;
if token_type=end_token_type then
next_token
else
syntax_scan(error_nr);
end;
boolean procedure make_string(st);
<*----------------------------------------------------------------*>
<* Find type of string and insert this in string array *>
<* String array format: *>
<* st(1) : Length of used string array exc. this element *>
<* in half words. *>
<* st(2) : String type in same format as cmcl code. *>
<* st(3) : Text start (first word = HW < 12 + chars.) *>
<*----------------------------------------------------------------*>
integer array st;
begin
boolean interval,ok;
integer first_char,num_of_char,var_ref,i;
make_string:=true;
ok:=true;
for ii:=system(3,i,st) step 1 until i do
st(ii):=0;
if token_type<t_string or token_type>t_var then
begin
ok:=false;
goto make_string_end;
end;
if token_type=t_string then <* Text string *>
begin
long array la(1:max_string//6+3);
integer i,ts_length;
boolean tvs;
ts_length:=token_string_length;
tvs:=token_var_sub;
if ts_length>max_string then
begin
mcl_error(2);
ts_length:=max_string;
end;
for i:=1 step 1 until max_string//6+2 do
la(i):=token_text(i);
next_token;
interval:=false;
if token_type=t_int_start then
begin <* Interval *>
if -,tvs then
warning(4);
next_token;
if token_type<>t_number then
begin
ok:=false;
syntax_error(3);
goto make_string_end;
end;
first_char:=token_number_val;
if first_char<1 then
begin
first_char:=1;
syntax_error(4);
end;
if first_char>max_string+20 then
begin
first_char:=max_string;
syntax_error(4);
end;
next_token;
if token_type<>t_number then
begin
ok:=false;
syntax_error(3);
goto make_string_end;
end;
num_of_char:=token_number_val;
if num_of_char<1 then
begin
syntax_error(4);
num_of_char:=1;
end;
next_token;
if token_type<>t_int_end then
begin
ok:=false;
syntax_error(5);
goto make_string_end;
end;
next_token;
interval:=true;
end;
if (ts_length=0) or
(interval and -,tvs and (ts_length < first_char)) then
begin <* Null string *>
st(1):=2;
st(2):=0;
end
else
begin
if -,(interval or tvs) then
begin <* Constant string *>
st(1):=4+((ts_length+2)//3*2);
st(2):=5 shift 12;
st(3):=(st(1)-2) shift 12 + ts_length;
for i:=1 step 1 until (st(1)-2)//4 do
begin
st(2*i+2):=la(i) shift (-24);
st(2*i+3):=la(i) extract 24;
end;
end;
if tvs and -,interval then
begin <* Text with varsub *>
st(1):=4+((ts_length+2)//3*2);
st(2):=3 shift 12;
st(3):=(st(1)-2) shift 12 + ts_length;
for i:=1 step 1 until (st(1)-2)//4 do
begin
st(2*i+2):=la(i) shift (-24);
st(2*i+3):=la(i) extract 24;
end;
end;
if tvs and interval then
begin
st(1):=6+((ts_length+2)//3*2);
st(2):=4 shift 12;
st(3):=first_char shift 12 + num_of_char;
st(4):=(st(1)-4) shift 12 + ts_length;
for i:=1 step 1 until (st(1)-4)//4 do
begin
st(2*i+3):=la(i) shift (-24);
st(2*i+4):=la(i) extract 24;
end;
end;
if interval and -,tvs then
begin <* Constant string with interval !!!!! *>
integer new_length,sti,li,ch,index;
new_length:=if (ts_length-first_char+1)>=num_of_char then
num_of_char
else
ts_length-first_char+1;
sti:=0;
<* move new_length characters from la to st *>
<* starting at character first_char in la *>
for li:=first_char-1 step 1 until first_char+new_length-2 do
begin
<* find character li+1 in la *>
ch:=(la(li//6+1) shift (-8*(5-(li mod 6)))) extract 8;
index:=sti//3+4;
<* insert character in st at sti+1 *>
st(index):=st(index) + (ch shift (8*(2-(sti mod 3))));
sti:=sti+1;
end;
st(1):=4+((new_length+2)//3*2);
st(2):=5 shift 12;
st(3):=(st(1)-2) shift 12 + new_length;
end;
end;
end <* Text string *>
else
begin <* Variable or illegal string *>
var_ref:=token_number_val;
if token_type=t_errstring then
syntax_error(1);
next_token;
if token_type=t_int_start then
begin <* Interval *>
next_token;
if token_type<>t_number then
begin
ok:=false;
syntax_error(3);
goto make_string_end;
end;
first_char:=token_number_val;
if first_char<1 then
begin
first_char:=1;
syntax_error(4);
end;
if first_char>max_string+20 then
begin
first_char:=max_string;
syntax_error(4);
end;
next_token;
if token_type<>t_number then
begin
ok:=false;
syntax_error(3);
goto make_string_end;
end;
num_of_char:=token_number_val;
if num_of_char<1 then
begin
syntax_error(4);
num_of_char:=1;
end;
if num_of_char>max_string+20 then
begin
syntax_error(4);
num_of_char:=max_string;
end;
next_token;
if token_type<>t_int_end then
begin
ok:=false;
syntax_error(5);
goto make_string_end;
end;
next_token;
st(1):=4;
st(2):=2 shift 12 + var_ref;
st(3):=first_char shift 12 + num_of_char;
end
else
begin <* No interval *>
st(1):=2;
st(2):= 1 shift 12 + var_ref;
end;
end;
make_string_end:
if -,ok then
begin
st(1):=2;
st(2):=0; <* Empty string *>
make_string:=false;
while token_type=t_int_end or token_type=t_number do
next_token;
end;
end;
boolean procedure make_const_string(cst,point);
<*----------------------------------------------------------------*>
<* Find constant string and insert this in const *>
<* string array. *>
<* const string array format: *>
<* cst(1) : Number of char in text. *>
<* cst(2) : First char. in text. Converted to capital letter *>
<* cst(3) : Start of text *>
<*----------------------------------------------------------------*>
integer array cst;
boolean point;
begin
integer i,j;
for i:=system(3,j,cst) step 1 until j do
cst(i):=0;
if token_type=t_errstring then
begin
syntax_error(1);
cst(1):=cst(2):=cst(3):=0;
end
else
if token_type<>t_string then
begin
make_const_string:=false;
cst(1):=cst(2):=cst(3):=0;
end
else
begin
make_const_string:=true;
if token_var_sub then
mcl_error(3); <* Not constant *>
if token_string_length=0 then
cst(1):=cst(2):=cst(3):=0
else
begin
if token_string_length>max_string then
begin
mcl_error(2);
token_string_length:=max_string;
end;
cst(1):=token_string_length;
cst(2):=token_text(1) shift (-40);
for i:=1 step 1 until cst(1)//6+1 do
begin
cst(2*i+1):=token_text(i) shift (-24);
cst(2*i+2):=token_text(i) extract 24;
end;
end;
if cst(2)>='a' and cst(2)<='å' then
cst(2):=cst(2)-32;
if token_string_length=0 and point then
mcl_error(4);
next_token;
end;
end;
integer procedure insert_string(st,addr);
<*----------------------------------------------------------------*>
<* Insert st (string) in code at address addr *>
<* Return next unused address in next_free *>
<*----------------------------------------------------------------*>
value addr;
integer array st;
integer addr;
begin
integer i;
integer array field p;
p:=addr-1;
for i:=2 step 1 until st(1)//2+1 do
code.p(i-1):=st(i);
insert_string:=next_free:=addr+st(1);
end;
procedure select;
<*----------------------------------------------------------------*>
<* Produce code for SELECT *>
<* Structure of produced kode: *>
<*
-- bool exp -- ___
true address -- *
!----false address ! *
! -------------- ! *
! <--! *
! Action * First CASE
! *
! ---- jump ---- *
! address ---! *
! -------------- ! __*
!--> ! --*
! * More cases
! *
-------------- ! --*
otherwise !
action !
-------------- !
<--!
*>
<*----------------------------------------------------------------*>
begin
integer f_jump_hold_addr,
t_jump_hold_addr,
jump_hold_addr,
string_start;
integer field i;
integer var_ref;
integer array case_string(1:max_string//3+5);
f_jump_hold_addr:=jump_hold_addr:=0;
if token_type<>t_var then
begin
syntax_scan(6);
goto case_start;
end;
var_ref:=token_number_val;
next_token;
if token_type<>t_of then
begin
syntax_scan(7);
goto case_start;
end;
next_token;
if token_type<>t_case then
syntax_scan(8);
case_start:
while token_type=t_case do <* case *>
begin
s_line:=line_number;
next_token;
if f_jump_hold_addr<>0 then
begin
<* Indsæt adresse på ny bool-exp start i forrige bool-exp *>
i:=f_jump_hold_addr;
code.i:=next_free;
end;
if -,make_string(case_string) then
syntax_scan(1);
<* Indsæt bool-exp ud fra var_ref og case_string *>
if (case_string(2) shift (-12)=5) and
(case_string(3) extract 12<=3) then
begin
set_op(3,10);
code.op(4):=var_ref shift 12 +(case_string(3) extract 12);
code.op(5):=case_string(4);
end
else
if (case_string(2) shift (-12)=0) then
begin
set_op(3,10);
code.op(4):=var_ref shift 12;
code.op(5):=0;
end
else
begin
set_op(2,10);
code.op(5):=1 shift 12 + var_ref;
string_start:=find_string_address(case_string(1));
code.op(4):=string_start;
insert_string(case_string,string_start);
end;
code.op(2):=next_free;
f_jump_hold_addr:=op+6;
action;
s_line:=line_number;
<* Indsæt JUMP code efter action *>
set_op(1,4);
code.op(2):=jump_hold_addr;
jump_hold_addr:=op+4;
end;
if token_type=t_otherwise then
begin <* otherwise *>
<* Indsæt adresse på otherwise i sidste bool-exp *>
if make_code then
begin
i:=f_jump_hold_addr;
code.i:=next_free;
end;
next_token;
action;
end
else
if make_code then
begin <* fjern sidste jump *>
next_free:=next_free-4;
jump_hold_addr:=code.op(2);
code.op(1):=code.op(2):=0;
<* Indsæt adresse på endselect i sidste bool-exp *>
i:=f_jump_hold_addr;
code.i:=next_free;
end;
<*Indsæt baglens i jump_hold_adr addressen på første sætning efter select *>
if make_code then
while jump_hold_addr<>0 do
begin
i:=jump_hold_addr;
jump_hold_addr:=code.i;
code.i:=next_free;
end;
if token_type<>t_endselect then
syntax_error(9)
else
next_token; <* find first token after SELECT *>
select_end:
end; <* select *>
procedure while_sentence;
<*----------------------------------------------------------------*>
<* Produce code for WHILE *>
<* Structure of produced kode *>
<*
-- bool exp --
<-------!
true address -- !
!----false address ! !
! -------------- ! !
! <--! !
! action !
! !
! ---- jump ---- !
! address ---------
! --------------
!-->
*>
<*----------------------------------------------------------------*>
begin
integer prev_while_start;
integer field f_jump_hold_addr,t_jump_hold_addr;
boolean equal;
prev_while_start:=while_start;
while_start:=next_free;
make_bool_exp(t_do,11,f_jump_hold_addr,t_jump_hold_addr);
if make_code then
insert_jump(t_jump_hold_addr,next_free);
first_action:
action;
s_line:=line_number;
<* Insert jump code to while start *>
set_op(1,4);
code.op(2):=while_start;
if make_code then
insert_jump(f_jump_hold_addr,next_free);
while_start:=prev_while_start;
if token_type<>t_endwhile then
begin
syntax_error(12);
end
else
next_token;
end;
procedure menu;
<*----------------------------------------------------------------*>
<* Produce code for MENU *>
<*----------------------------------------------------------------*>
begin
integer field end_hold_addr,i;
integer col,line,num_of_point,menu_text_index,
ch_index,text_length,ncol;
integer array menu_text(1:640),point_table(1:3*25);
integer array field entry,menu_op;
integer array menu_line(1:max_string//3+5);
boolean first_text,ctrls;
boolean array unique(0:127);
procedure next_line;
<* Insert NL in menu text *>
begin
if menu_line(2)>31 then
begin
line:=line+1;
if line>24 then
warning(2);
pack_char(10);
end;
end;
procedure pack_char(ch);
<* Insert a character in menu text *>
value ch;
integer ch;
begin
menu_text(menu_text_index):=menu_text(menu_text_index)+
(ch shift (8*ch_index));
ch_index:=ch_index-1;
if ch_index=-1 then
begin
menu_text_index:=menu_text_index+1;
if menu_text_index>640 then
comp_error(9);
ch_index:=2;
end;
end;
procedure pack_const_string(cst);
<* Indsert string in cst in menu text *>
integer array cst;
begin
integer i,cst_text_index,cst_ch_index;
cst_text_index:=0;
cst_ch_index:=-2;
for i:=1 step 1 until cst(1) do
begin
pack_char((cst(3+cst_text_index) shift (cst_ch_index*8)) extract 8);
cst_ch_index:=cst_ch_index+1;
if cst_ch_index=1 then
begin
cst_text_index:=cst_text_index+1;
cst_ch_index:=-2;
end;
end;
end;
if token_type<>t_number then
begin
syntax_error(3);
col:=line:=-1;
goto point_start;
end;
col:=token_number_val;
if col>79 then
begin
mcl_error(6);
col:=79;
end;
next_token;
if token_type<>t_number then
begin
syntax_error(3);
col:=line:=-1;
goto point_start;
end;
line:=token_number_val;
if line>24 then
begin
mcl_error(7);
line:=1;
end;
next_token;
if -,make_const_string(menu_line,false) then
begin
syntax_error(1);
line:=col:=-1;
end;
set_op(22,8);
code.op(2):=line shift 12;
point_start:
if token_type>t_endinclude then
begin
if col<>-1 then
syntax_error(13);
menu_line(1):=menu_line(2):=1;
while token_type>t_endinclude do
next_token;
end;
menu_op:=op; <* Rem. menu code pos. *>
menu_text_index:=1;
for i:=1 step 1 until 640 do
menu_text(i):=0;
ch_index:=2;
end_hold_addr:=0;
num_of_point:=0;
if menu_line(1)>0 and menu_line(2)>31 then
begin <* Write headline centred in 80 char. *>
for i:=1 step 1 until (80-menu_line(1))//2 do
pack_char(32);
pack_const_string(menu_line);
end;
line:=line+1;
for ii:=0 step 1 until 127 do
unique(ii):=false;
ctrls:=true;
while token_type=t_point or token_type=t_text do
begin <* POINT and TEXT *>
if token_type=t_text then
begin <* TEXT *>
next_token;
if token_type=t_at then
begin
next_token;
if token_type<>t_number then
syntax_scan(3)
else
begin
ncol:=token_number_val;
if ncol>79 then
begin
mcl_error(6);
ncol:=1;
end;
end;
next_token;
end
else
ncol:=col;
if -,make_const_string(menu_line,false) then
syntax_scan(1);
next_line;
if menu_line(1)>0 and menu_line(2)>31 then
begin <* Insert text at collum ncol *>
for i:=1 step 1 until ncol do
pack_char(32);
pack_const_string(menu_line);
end;
if menu_line(1)=0 then
begin
menu_line(2):=32;
next_line;
end;
end
else
begin <* POINT *>
integer entry_type;
num_of_point:=num_of_point+1;
if num_of_point>25 then
begin
num_of_point:=1;
syntax_error(14);
end;
entry:=(num_of_point-1)*6;
next_token;
<* if token_type=t_at then
begin
next_token;
if token_type<>t_number then
syntax_scan(3)
else
begin
ncol:=token_number_val;
if ncol>79 then
begin
mcl_error(6);
ncol:=1;
end;
end;
next_token;
end
else *>
ncol:=col;
if -,make_const_string(menu_line,true) then
syntax_scan(1);
if unique(menu_line(2)) then
mcl_error(10);
unique(menu_line(2)):=true;
point_table.entry(2):=ncol shift 12 + line;
next_line;
if menu_line(1)>0 and menu_line(2)>31 then
begin <*Insert text at collum ncol *>
for i:=1 step 1 until ncol do
pack_char(32);
pack_const_string(menu_line);
ctrls:=false; <* Printeble menu point used *>
end;
<* Find entry type bits *>
entry_type:=0;
if num_of_point=1 then
entry_type:=1; <* Top bit *>
if menu_line(2)<32 then
entry_type:=entry_type+8; <* Ctlr char bit *>
point_table.entry(1):=menu_line(2) shift 12 + entry_type;
point_table.entry(3):=next_free; <* Action address *>
action;
s_line:=line_number;
set_op(1,4); <* Insert jump to end-menu after action code *>
code.op(2):=end_hold_addr;
end_hold_addr:=op+4;
end;
if token_type>t_endinclude then
begin
syntax_error(15);
while token_type>t_endinclude do
next_token;
end;
end; <* point and text *>
<* Indsert bottom bit in last entry *>
if num_of_point>0 then
begin
entry:=6*(num_of_point-1);
point_table.entry(1):=point_table.entry(1)+2;
end
else
mcl_error(1);
if ctrls then <* Only controls are used in points *>
mcl_error(1);
<* Insert last menu line in all ctrl point *>
for entry:=0 step 6 until 6*(num_of_point-1) do
if (point_table.entry(1) shift (-12))<32 then
point_table.entry(2):=col shift 12 + line;
<* Find menu text length *>
text_length:=3*(menu_text_index-1)+(2-ch_index);
first_text:=true;
menu_text_index:=0;
while text_length>0 do
begin <* Insert menu text entries *>
integer room;
room:=512-(next_free mod 512);
if (room<20) and (((text_length//3)*2+4)>room) then
begin <* No room for text; min. 30 char in one text-entry *>
next_free:=next_free+room;
room:=512;
end;
if first_text then
code.menu_op(4):=next_free; <* Insert address of first text *>
entry:=next_free-1; <* Entry in code *>
first_text:=false;
if ((text_length//3)*2+4)<room then
begin <* Last text entry *>
code.entry(1):=0;
code.entry(2):=((text_length+2)//3+1)*2 shift 12 + text_length;
end
else
begin
code.entry(1):=next_free+room; <* Next text start *>
code.entry(2):=(room-2) shift 12 + ((room-4)//2)*3;
end;
for i:=1 step 1 until (code.entry(2) shift (-12))//2 do
code.entry(2+i):=menu_text(i+menu_text_index);
next_free:=next_free+(code.entry(2) shift (-12))+2;
text_length:=text_length-code.entry(2) extract 12;
menu_text_index:=menu_text_index+(code.entry(2) extract 12)//3;
end;
<* Find room for point table (max. 150 hw) *>
entry:=find_string_address(6*num_of_point)-1;
code.menu_op(3):=entry+1; <* Insert address of first point *>
for i:=1 step 1 until 3*num_of_point do
code.entry(i):=point_table(i);
next_free:=entry+1+6*num_of_point;
code.menu_op(2):=code.menu_op(2)+num_of_point;
<* indsæt i end_hold_jump *>
if make_code then
while end_hold_addr<>0 do
begin
i:=end_hold_addr;
end_hold_addr:=code.i;
code.i:=next_free;
end;
if token_type<>t_endmenu then
syntax_error(15)
else
next_token;
end; <* menu *>
procedure attention;
<*----------------------------------------------------------------*>
<* Produce code for ATTENTION *>
<*----------------------------------------------------------------*>
begin
integer field end_att_hold_addr;
integer array proc_string(1:max_string//3+5);
if in_attention or in_include then
mcl_error(9);
in_attention:=true;
att_start:=next_free;
if -,make_string(proc_string) then
begin
syntax_scan(1);
goto first_action;
end;
set_op(4,10+proc_string(1));
insert_string(proc_string,op+9);
code.op(2):=next_free;
if token_type<>t_var then
begin
syntax_scan(6);
goto first_action;
end;
code.op(4):=token_number_val shift 12;
end_att_hold_addr:=op+6;
next_token;
first_action:
action;
if make_code then
code.end_att_hold_addr:=next_free;
s_line:=line_number;
set_op(5,2);
in_attention:=false;
if token_type<>t_endattention then
syntax_error(16)
else
next_token;
end;
procedure include;
<*----------------------------------------------------------------*>
<* Produce code for INCLUDE *>
<*----------------------------------------------------------------*>
begin
integer field end_inc_hold_addr;
integer array proc_string,pool_string,local_string(1:max_string//3+5);
integer bufs;
if in_attention or in_include then
mcl_error(9);
in_include:=true;
att_start:=next_free;
if -,make_string(pool_string) then
begin
syntax_scan(1);
goto first_action;
end;
if -,make_string(proc_string) then
begin
syntax_scan(1);
goto first_action;
end;
if -,make_string(local_string) then
begin
syntax_scan(1);
goto first_action;
end;
set_op(6,16+local_string(1));
insert_string(local_string,op+15);
code.op(6):=find_string_address(pool_string(1));
insert_string(pool_string,code.op(6));
code.op(7):=find_string_address(proc_string(1));
insert_string(proc_string,code.op(7));
code.op(2):=next_free;
if token_type<>t_number then
begin
syntax_scan(3);
goto first_action;
end;
bufs:=token_number_val;
if bufs>1 then
mcl_error(5);
next_token;
if token_type<>t_number then
begin
syntax_scan(3);
goto first_action;
end;
code.op(5):=bufs shift 12 + token_number_val;
next_token;
if token_type<>t_var then
begin
syntax_scan(6);
goto first_action;
end;
code.op(4):=token_number_val shift 12;
end_inc_hold_addr:=op+6;
next_token;
first_action:
action;
if make_code then
code.end_inc_hold_addr:=next_free;
s_line:=line_number;
set_op(7,2);
in_include:=false;
if token_type<>t_endinclude then
syntax_error(17)
else
next_token;
end;
procedure at;
<*----------------------------------------------------------------*>
<* Produce code for AT *>
<*----------------------------------------------------------------*>
begin
integer col,line;
if token_type<>t_number then
syntax_scan(3)
else
begin
col:=token_number_val;
if col>79 then
begin
mcl_error(6);
col:=79;
end;
next_token;
if token_type=t_number then
begin
line:=token_number_val;
if line>24 then
begin
mcl_error(7);
line:=24;
end;
next_token;
end
else
begin
line:=-1;
if token_type>t_echo then
syntax_scan(18);
end;
set_op(8,4);
code.op(2):=col shift 12 + (line extract 12);
end;
end;
procedure write_sentence;
<*----------------------------------------------------------------*>
<* Produce code for WRITE *>
<*----------------------------------------------------------------*>
begin
integer array write_string(1:max_string//3+5);
if -,make_string(write_string) then
syntax_scan(1)
else
if write_string(2) shift (-12) <> 0 then
begin <* Non empty string *>
set_op(9,6+write_string(1));
insert_string(write_string,op+5);
code.op(2):=next_free;
end;
end;
procedure nl;
<*----------------------------------------------------------------*>
<* Produce code for NL *>
<*----------------------------------------------------------------*>
begin
set_op(10,2);
end;
procedure erase;
<*----------------------------------------------------------------*>
<* Produce code for ERASE *>
<*----------------------------------------------------------------*>
begin
set_op(23,2);
end;
procedure read_sentence;
<*----------------------------------------------------------------*>
<* Produce code for READ *>
<*----------------------------------------------------------------*>
begin
integer array read_string(1:max_string//3+5);
integer char_to_read;
if -,make_string(read_string) then
syntax_scan(1)
else
if token_type<>t_number then
char_to_read:=-1
else
begin
char_to_read:=token_number_val;
if char_to_read>max_string or char_to_read<1 then
begin
mcl_error(5);
char_to_read:=1;
end;
next_token;
end;
if token_type<>t_var then
syntax_scan(6)
else
begin
if read_string(2) shift (-12) <> 0 then
begin <* Non empty string *>
set_op(9,6+read_string(1));
insert_string(read_string,op+5);
code.op(2):=next_free;
end;
set_op(11,4);
code.op(2):=char_to_read shift 12 + token_number_val;
next_token;
end;
end;
procedure get;
<*----------------------------------------------------------------*>
<* Produce code for GET *>
<*----------------------------------------------------------------*>
begin
integer char_to_get;
if -,(in_attention or in_include) then
warning(1);
if token_type<>t_number then
syntax_scan(3)
else
begin
char_to_get:=token_number_val;
if char_to_get>max_string or char_to_get<1 then
mcl_error(5);
next_token;
if token_type<>t_var then
syntax_scan(6)
else
begin
set_op(12,4);
code.op(2):=char_to_get shift 12 + token_number_val;
next_token;
end;
end;
end;
procedure let;
<*----------------------------------------------------------------*>
<* Produce code for LET *>
<*----------------------------------------------------------------*>
begin
integer var_ref;
integer array let_string(1:max_string//3+5);
if token_type<>t_var then
syntax_scan(6)
else
begin
var_ref:=token_number_val;
next_token;
if token_type<>t_equal then
syntax_scan(10)
else
begin
next_token;
if -,make_string(let_string) then
syntax_scan(1)
else
begin
set_op(13,8+let_string(1));
insert_string(let_string,op+7);
code.op(2):=next_free;
code.op(3):=var_ref shift 12;
end;
end;
end;
end;
procedure send;
<*----------------------------------------------------------------*>
<* Produce code for SEND *>
<*----------------------------------------------------------------*>
begin
integer array send_string(1:max_string//3+5);
if -,(in_attention or in_include) then
warning(1);
if -,make_string(send_string) then
syntax_scan(1)
else
begin
set_op(14,6+send_string(1));
insert_string(send_string,op+5);
code.op(2):=next_free;
end;
end;
procedure if_sentence;
<*----------------------------------------------------------------*>
<* Produce code for IF *>
<* Structure of produced kode for IF THEN ELSE *>
<*
-- bool exp --
true address --
!----false address !
! -------------- !
! <--!
! action
!
! ---- jump ----
! address ---!
! -------------- !
!--> else !
action !
-------------- !
<--!
Structure of produced kode for IF THEN
-- bool exp --
true address --
!----false address !
! -------------- !
! <--!
! action
!
! --------------
!-->
*>
<*----------------------------------------------------------------*>
begin
integer field f_jump_hold_addr,t_jump_hold_addr;
boolean equal;
make_bool_exp(t_then,19,f_jump_hold_addr,t_jump_hold_addr);
if make_code then
insert_jump(t_jump_hold_addr,next_free);
first_action:
action;
s_line:=line_number;
if token_type=t_else then
begin
set_op(1,4);
if make_code then
insert_jump(f_jump_hold_addr,next_free);
f_jump_hold_addr:=op+3;
next_token;
action;
end;
if make_code then
insert_jump(f_jump_hold_addr,next_free);
if token_type<>t_endif then
begin
syntax_error(20);
end
else
next_token;
end;
procedure execute;
<*----------------------------------------------------------------*>
<* Produce code for EXECUTE *>
<*----------------------------------------------------------------*>
begin
integer array execute_string(1:max_string//3+5);
if -,make_string(execute_string) then
syntax_scan(1)
else
begin
set_op(15,8+execute_string(1));
insert_string(execute_string,op+7);
code.op(2):=next_free;
if token_type<>t_var then
syntax_scan(6)
else
begin
code.op(3):=token_number_val shift 12;
next_token;
end;
end;
end;
procedure note;
<*----------------------------------------------------------------*>
<* Produce code for NOTE *>
<*----------------------------------------------------------------*>
begin
integer array note_string(1:max_string//3+5);
if -,make_string(note_string) then
syntax_scan(1)
else
if use_note then
begin
set_op(9,6+note_string(1));
insert_string(note_string,op+5);
code.op(2):=next_free;
set_op(10,2);
end;
end;
procedure direct;
<*----------------------------------------------------------------*>
<* Produce code for DIRECT *>
<*----------------------------------------------------------------*>
begin
if -,(in_attention or in_include) then
warning(1);
if token_type<>t_var then
syntax_scan(6)
else
begin
set_op(16,4);
code.op(2):=token_number_val shift 12;
next_token;
end;
end;
procedure loop;
<*----------------------------------------------------------------*>
<* Produce code for LOOP *>
<*----------------------------------------------------------------*>
begin
if in_attention and (while_start<att_start) then
set_op(5,2);
if in_include and (while_start<att_start) then
set_op(5,2);
set_op(1,4);
code.op(2):=while_start;
end;
procedure exit;
<*----------------------------------------------------------------*>
<* Produce code for EXIT *>
<*----------------------------------------------------------------*>
begin
integer array exit_string(1:max_string//3+5);
if in_attention then
set_op(5,2);
if in_include then
set_op(7,2);
if -,make_string(exit_string) then
syntax_scan(1);
set_op(17,2+exit_string(1));
insert_string(exit_string,op+3);
end;
procedure output;
<*----------------------------------------------------------------*>
<* Produce code for OUTPUT *>
<*----------------------------------------------------------------*>
begin
if token_type=t_on then
begin
next_token;
set_op(18,2);
end
else
if token_type=t_off then
begin
next_token;
set_op(19,2);
end
else
syntax_scan(21);
end;
procedure echo;
<*----------------------------------------------------------------*>
<* Produce code for ECHO *>
<*----------------------------------------------------------------*>
begin
if token_type=t_on then
begin
next_token;
set_op(20,2);
end
else
if token_type=t_off then
begin
next_token;
set_op(21,2);
end
else
syntax_scan(21);
end;
procedure convert;
<*----------------------------------------------------------------*>
<* Produce code for CONVERT *>
<*----------------------------------------------------------------*>
begin
if token_type<>t_var then
syntax_scan(6)
else
begin
set_op(24,4);
code.op(2):=token_number_val shift 12;
next_token;
end;
end;
procedure action;
<*----------------------------------------------------------------*>
<* Call procedures to produce code for the *>
<* sentence in a action, return if next keyword *>
<* is a 'action-end' *>
<*----------------------------------------------------------------*>
begin
integer tt;
while token_type>t_endinclude do
begin
if (token_type>=t_select) and (token_type<=t_echo) then
begin
tt:=token_type-t_endinclude;
s_line:=line_number;
next_token;
case tt of
begin
select;
while_sentence;
menu;
attention;
include;
at;
write_sentence;
nl;
erase;
read_sentence;
get;
let;
send;
if_sentence;
execute;
note;
direct;
loop;
exit;
output;
convert;
echo
end;
end;
if token_type>t_echo then
begin
<* Error, not a sentence start *>
if token_type=t_unknown then <* Unknown keyword *>
begin
next_token;
syntax_scan(2);
end
else
syntax_scan(18);
end;
end; <* Other = end action *>
end;
integer procedure list_string(addr);
<*----------------------------------------------------------------*>
<* Used by list-code. List string format *>
<* starting at address addr *>
<*----------------------------------------------------------------*>
value addr;
integer addr;
begin
integer type;
integer field i;
write(out,<:<10>:>,<<dddddd>,addr,<:+ :>);
i:=addr+1;
type:=code.i shift (-12);
if type<0 or type>5 then
write(out,<:***String error:>,type)
else
begin
case type+1 of
begin
<* 0 *> begin
write(out,<: Empty string:>);
list_string:=addr+2;
end;
<* 1 *> begin
write(out,<: Variable :>);
outchar(out,(code.i extract 12)+65);
list_string:=addr+2;
end;
<* 2 *> begin
write(out,<: Variable with interval :>);
w_h(i,true);
w_h(i+1,false);
w_h(i+2,false);
list_string:=addr+4;
end;
<* 3 *> begin
write(out,<: Text with var.sub :>);
list_string:=list_text(addr+2);
end;
<* 4 *> begin
write(out,<: Text with var.sub and interval :>);
w_h(i+1,false);
w_h(i+2,false);
list_string:=list_text(addr+4);
end;
<* 5 *> begin
write(out,<: Constant text :>);
list_string:=list_text(addr+2);
end;
end;
end;
end;
integer procedure list_text(addr);
<*----------------------------------------------------------------*>
<* Used by code-list. List text starting at addr *>
<*----------------------------------------------------------------*>
value addr;
integer addr;
begin
integer array field iaf;
integer field inx;
integer i,j,ch;
inx:=addr+1;
write(out,<:<10>:>,<<dddddd>,addr,<:+ Text:>,<< d>,
code.inx shift (-12), code.inx extract 12);
iaf:=inx;
write(out,<: <60>:>);
for i:=1 step 1 until (code.inx shift (-12))//2 do
for j:=-16 step 8 until 0 do
begin
ch:=(code.iaf(i) shift j) extract 8;
if ch<32 then
begin
if ch=0 then
goto text_end;
write(out,<:^:>);
ch:=ch+64;
end;
if ch>127 then
begin
write(out,<:&:>);
ch:=ch-63;
end;
outchar(out,ch);
end;
text_end:
write(out,<:<62>:>);
list_text:=addr+(code.inx shift (-12));
end;
procedure w_addr(addr,text);
integer field addr;
string text;
begin
write(out,<:<10>:>,<<dddddd>,addr,<:+ :>,
text,<< d>,code.addr);
end;
procedure w_h(addr,var);
boolean field addr;
boolean var;
begin
write(out,<:<10>:>,<<dddddd>,addr,<:+ :>);
if var then
begin
write(out,<:Variable :>);
outchar(out,(code.addr extract 12)+65);
end
else
write(out,<< d>,code.addr extract 12);
end;
procedure code_list(op_addr,stop_addr);
<*----------------------------------------------------------------*>
<* List code formats from address op_addr *>
<* until address stop_addr *>
<*----------------------------------------------------------------*>
value stop_addr;
integer op_addr,stop_addr;
begin
integer op_code;
while op_addr<stop_addr do
begin
op:=op_addr-1;
op_code:=code.op(1) shift (-12);
if op_code<0 or op_code>24 then
begin
write(out,<:<10>:>,<<dddddd>,op_addr,
<: ***error in op code :>,op_code);
while op_code<0 or op_code>24 do
begin
op_addr:=op_addr+2;
op:=op_addr-1;
op_code:=code.op(1) shift (-12);
write(out,<< d>,op_code);
end;
end;
write(out,<:<10>:>,<<dddddd>,op_addr,<:::>,
<<dddd >,code.op(1) extract 12,
case op_code+1 of
(<:New segment:>,
<:Jump:>,
<:Bool-exp:>,
<:Red-bool-exp:>,
<:Attention:>,
<:Endattention:>,
<:Include:>,
<:Endinclude:>,
<:At:>,
<:Write:>,
<:Nl:>,
<:Read:>,
<:Get:>,
<:Let:>,
<:Send:>,
<:Execute:>,
<:Direct:>,
<:Exit:>,
<:Output-on:>,
<:Output-off:>,
<:Echo-on:>,
<:Echo-off:>,
<:Menu:>,
<:Erase:>,
<:Convert:>));
case op_code+1 of
begin
<* 0 *> begin
op_addr:=(op_addr shift (-9)+1) shift 9;
end;
<* 1 *> begin
op_addr:=op_addr+4;
w_addr(op+3,<:addr::>);
end;
<* 2 *> begin
op_addr:=if code.op(2)<code.op(3) then
code.op(2)
else
code.op(3);
w_addr(op+3,<:equal addr::>);
w_addr(op+5,<:not equal addr::>);
w_addr(op+7,<:right s addr::>);
list_string(op+9);
list_string(code.op(4));
end;
<* 3 *> begin
op_addr:=if code.op(2)<code.op(3) then
code.op(2)
else
code.op(3);
w_addr(op+3,<:equal addr::>);
w_addr(op+5,<:not equal addr::>);
w_h(op+7,true);
w_h(op+8,false);
write(out,<: :>);
for ii:=-16 step 8 until -24+8*(code.op(4) extract 12) do
outchar(out,code.op(5) shift ii);
end;
<* 4 *> begin
op_addr:=code.op(2);
w_addr(op+3,<:next op.:>);
w_addr(op+5,<:end att addr::>);
w_h(op+7,true);
list_string(op+9);
end;
<* 5 *> begin
op_addr:=op_addr+2;
end;
<* 6 *> begin
op_addr:=code.op(2);
w_addr(op+3,<:next op.:>);
w_addr(op+5,<:end inc addr::>);
w_h(op+7,true);
w_h(op+9,false);
w_h(op+10,false);
w_addr(op+11,<:pool s addr::>);
w_addr(op+13,<:proc s addr::>);
list_string(op+15);
list_string(code.op(6));
list_string(code.op(7));
end;
<* 7 *> begin
op_addr:=op_addr+2;
end;
<* 8 *> begin
op_addr:=op_addr+4;
w_h(op+3,false);
w_h(op+4,false);
end;
<* 9 *> begin
op_addr:=code.op(2);
w_addr(op+3,<:next op.:>);
list_string(op+5);
end;
<* 10 *> begin
op_addr:=op_addr+2;
end;
<* 11 *> begin
op_addr:=op_addr+4;
w_h(op+3,false);
w_h(op+4,true);
end;
<* 12 *> begin
op_addr:=op_addr+4;
w_h(op+3,false);
w_h(op+4,true);
end;
<* 13 *> begin
op_addr:=code.op(2);
w_addr(op+3,<:next op.:>);
w_h(op+5,true);
list_string(op+7);
end;
<* 14 *> begin
op_addr:=code.op(2);
w_addr(op+3,<:next op.:>);
list_string(op+5);
end;
<* 15 *> begin
op_addr:=code.op(2);
w_addr(op+3,<:next op.:>);
w_h(op+5,true);
list_string(op+7);
end;
<* 16 *> begin
op_addr:=op_addr+4;
w_h(op+3,true);
end;
<* 17 *> begin
op_addr:=list_string(op+3);
end;
<* 18 *> begin
op_addr:=op_addr+2;
end;
<* 19 *> begin
op_addr:=op_addr+2;
end;
<* 20 *> begin
op_addr:=op_addr+2;
end;
<* 21 *> begin
op_addr:=op_addr+2;
end;
<* 22 *> begin
integer next_text,point_table,num_of_point,point;
long array field laf;
integer field i;
integer pch;
op_addr:=op_addr+8;
w_h(op+3,false);
w_h(op+4,false);
num_of_point:=code.op(2) extract 12;
w_addr(op+5,<:first point:>);
w_addr(op+7,<:menu text:>);
next_text:=code.op(4);
point_table:=code.op(3);
code_list(op_addr,code.op(4));
while next_text<>0 do
begin
write(out,<:<10>:>,<<dddddd>,next_text,<:+ Menu text:>);
op:=next_text-1;
next_text:=code.op(1);
if next_text>0 then
w_addr(op+1,<:next text:>);
write(out,<< d>,code.op(2) shift (-12), code.op(2) extract 12);
laf:=op+4;
write(out,<:<10>--------Menu-text-start---<10>:>,code.laf,
<:<10>--------Menu-text-end-----<10>:>);
end;
for op:=point_table-1 step 6 until
(num_of_point-1)*6+point_table-1 do
begin
write(out,<:<10>:>,<<dddddd>,op+1,<:+ Point :>);
pch:=code.op(1) shift (-12);
if pch < 32 then
begin
pch:=pch+64;
write(out,<:^:>);
end
else
write(out,<: :>);
outchar(out,pch);
write(out,<: :>);
for ii:=-11 step 1 until 0 do
write(out,<<d>,(code.op(1) shift ii) extract 1);
w_h(op+3,false);
w_h(op+4,false);
w_addr(op+5,<:action:>);
end;
op_addr:=point_table+6*num_of_point;
end;
<* 23 *> begin
op_addr:=op_addr+2;
end;
<* 24 *> begin
op_addr:=op_addr+4;
w_h(op+3,true);
end;
end;
end;
end;
trap(traped);
init_compiler;
if list_source then
write_headline;
init_scan;
open(source_text,4,source_file,0);
if monitor(42,source_text,ii,tail)<>0 then
init_error(3);
if tail(9)<>0 then
init_error(5);
line_number:=0;
get_new_line;
next_token;
while token_type<>t_end_file do
begin
action;
if token_type<>t_end_file then
begin
syntax_error(22);
while (token_type<t_select or token_type>t_echo)
and token_type<>t_end_file do
next_token;
end;
end;
if false then
traped: comp_error(alarmcause extract 24);
stop:
<* Insert exit at end *>
s_line:=line_number;
set_op(17,10);
<* Default exit text *>
code.op(2):=5 shift 12;
code.op(3):=6 shift 12 + 5;
code.op(4):= long <:exi:> shift (-24) extract 24;
code.op(5):= long <:t :> shift (-24) extract 24;
if show_code and make_code then
begin
write_headline;
write(out,<:<10>Code list::>);
code_list(0,next_free);
end;
if make_code and make_cmcl then
begin
real array field raf;
open(cmcl_code,4,cmcl_file,0);
monitor(42,cmcl_code,ii,tail);
tail(1):=(next_free//512)+1;
tail(6):=systime(7,0,rr);
tail(9):=29 shift 12; <* Contents key 29 *>
tail(10):=next_free; <* Size of code in hw's *>
if monitor(44,cmcl_code,ii,tail)<>0 then
begin
for ii:=2,3,4,5,7,8 do
tail(ii):=0;
if monitor(40,cmcl_code,ii,tail)<>0 then
init_error(6);
end;
for raf:=-1 step 512 until next_free-2 do
begin
outrec6(cmcl_code,512);
tofrom(cmcl_code,code.raf,512);
end;
close(cmcl_code,true);
end;
write(out,<:<10>mcl end :>);
if make_code then
write(out,<: code:>,<< d>,next_free,<:<10>:>)
else
write(out,<: no code generated<10>:>);
if warnings then
errorbits:=1 shift 1;
if -,make_code then
errorbits:=3;
end;
end; <* program *>
▶EOF◀