|
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: 19200 (0x4b00)
Types: TextFile
Names: »talgoltask«
└─⟦621cfb9a2⟧ Bits:30002817 RC8000 Dump tape fra HCØ. Detaljer om "HC8000" projekt.
└─⟦0364f57e3⟧
└─⟦ef5fa0e68⟧ »jtas«
└─⟦667bb35d6⟧ Bits:30007480 RC8000 Dump tape fra HCØ.
└─⟦4334b4c0b⟧
└─⟦ef5fa0e68⟧ »jtas«
└─⟦this⟧
algoltask
begin
! call:
<task name> = algoltask <external procedure name> list.<yes/no> survey.<yes/no>
algoltask changes the content of the fp command stack in order to
make fp perform:
1) prelinking of the external procedure,
2) algol translation of a small program calling the procedure,
3) start createtask to make an internal process in which the
translated algol program is run. set_entry will then stop
execution and createtask will dump the code on a file named
<task name>.
if execution is stopped in an error situation (by 'fatal_error') the
contents of the fp stack is not changed and mode bits are ok.no warning.yes.
otherwise mode bit 11 is set (and cleared in createtask if no errors
are detected in between).
version 27.11.1980 jom !
!sections 10
\f
! p r o c e d u r e d e c l a r a t i o n s !
! main procedures !
procedure read_command (.w3.; w2);
procedure wrk_names (.w3.);
procedure write_prg (.w3.);
procedure new_fp_stack (.w3.);
! common procedures !
procedure copy_name (.w3.; w2; w1);
procedure fatal_error (.w3.; w2; w1; w0);
! test procedures !
procedure debug_output (.w3.; w2);
! p r o c e d u r e d e c l a r a t i o n s e n d !
\f
! d a t a d e c l a r a t i o n s p a g e 1 !
incode
word output_on := 1; ! = 0 if no output is wanted !
! the following commands are transfered to fp command stack:
( algoltask
<wrk1> = prelinker <ext name> list.<yes/no>
if ok.yes
( <wrk2> = algol <wrk3> message.no survey.<yes/no>
if warning.no ok.yes
<task name> = createtask <wrk2>
clear temp <wrk1> <wrk2> )
clear temp <wrk3>
if 11.yes
mode 11.no ok.no warning.yes )
!
word start_of_commands;
array (0:1) atask_word of byte := 0 10; text (11) atask_text := "algoltask";
array (0:1) wrk1_word1 of byte := 2 10; text (11) wrk1_text1;
array (0:1) pre_word of byte := 6 10; text (11) pre_text := "prelinker";
array (0:1) ext_word of byte := 4 10; text (11) ext_text;
array (0:1) list_word1 of byte := 4 10; text (11) list_text1 := "list";
array (0:1) no_word4 of byte := 8 10; text (11) no_text4 := "no";
array (0:1) if_word1 of byte := 2 10; text (11) if_text1 := "if";
array (0:1) ok_word1 of byte := 4 10; text (11) ok_text1 := "ok";
array (0:1) yes_word1 of byte := 8 10; text (11) yes_text1 := "yes";
\f
! d a t a d e c l a r a t i o n s p a g e 2 !
array (0:1) nl_word1 of byte := 2 2;
array (0:1) wrk2_word1 of byte := 0 10; text (11) wrk2_text1;
array (0:1) algol_word of byte := 6 10; text (11) algol_text := "algol";
array (0:1) wrk3_word1 of byte := 4 10; text (11) wrk3_text1;
array (0:1) mess_word of byte := 4 10; text (11) mess_text := "message";
array (0:1) no_word3 of byte := 8 10; text (11) no_text3 := "no";
array (0:1) surv_word of byte := 4 10; text (11) surv_text := "survey";
array (0:1) no_word5 of byte := 8 10; text (11) no_text5 := "no";
array (0:1) if_word2 of byte := 2 10; text (11) if_text2 := "if";
array (0:1) warn_word2 of byte := 4 10; text (11) warn_text2 := "warning";
array (0:1) no_word2 of byte := 8 10; text (11) no_text2 := "no";
array (0:1) ok_word2 of byte := 4 10; text (11) ok_text2 := "ok";
array (0:1) yes_word2 of byte := 8 10; text (11) yes_text2 := "yes";
array (0:1) task_word of byte := 2 10; text (11) task_text;
array (0:1) crtsk_word of byte := 6 10; text (11) crtsk_text := "createtask";
array (0:1) wrk2_word2 of byte := 4 10; text (11) wrk2_text2;
array (0:1) clea_word1 of byte := 2 10; text (11) clea_text1 := "clear";
array (0:1) temp_word1 of byte := 4 10; text (11) temp_text1 := "temp";
array (0:1) wrk1_word2 of byte := 4 10; text (11) wrk1_text2;
array (0:1) wrk2_word3 of byte := 4 10; text (11) wrk2_text3;
array (0:1) rpar_word1 of byte := -2 2;
array (0:1) clea_word2 of byte := 2 10; text (11) clea_text2 := "clear";
array (0:1) temp_word2 of byte := 4 10; text (11) temp_text2 := "temp";
array (0:1) wrk3_word2 of byte := 4 10; text (11) wrk3_text2;
\f
! d a t a d e c l a r a t i o n s p a g e 3 !
array (0:1) if_word3 of byte := 2 10; text (11) if_text3 := "if";
array (0:1) m11_word1 of byte := 4 4; word n11_word1 := 11;
array (0:1) yes_word6 of byte := 8 10; text (11) yes_text6 := "yes";
array (0:1) mode_word1 of byte := 2 10; text (11) mode_text1 := "mode";
array (0:1) m11_word2 of byte := 4 4; word n11_word2 := 11;
array (0:1) no_word6 of byte := 8 10; text (11) no_text6 := "no";
array (0:1) warn_word1 of byte := 4 10; text (11) warn_text1 := "warning";
array (0:1) yes_word3 of byte := 8 10; text (11) yes_text3 := "yes";
array (0:1) ok_word3 of byte := 4 10; text (11) ok_text3 := "ok";
array (0:1) no_word7 of byte := 8 10; text (11) no_text7 := "no";
array (0:1) rpar_word2 of byte := -2 2;
array (0:1) nl_word2 of byte := 2 2;
array (0:1) end_word of byte := -4 0;
word end_of_commands;
! d a t a d e c l a r a t i o n s e n d !
\f
! s t a r t m a i n p r o g !
begin
! w2 points to start of fp command stack, w3 to program name !
if w0 := (w3).byte <> 6 then output_on := w3 := 0;
! read and test calling command !
read_command (.w3., w2);
! generate and store wrk names !
wrk_names (.w3.);
! write algol program calling <wrk1> !
write_prg (.w3.);
! copy new commands to fp command stack !
new_fp_stack (.w3.);
! set mode bit 11 - cleared by createtask if no problems !
w3 := fp(51); (w3).word := w0 := (w3).word or 4096;
! debug: write commands in fp stack !
! debug_output (.w3., w2); !
end;
! m a i n p r o g e n d !
\f
! p r o c e d u r e r e a d _ c o m m a n d p a g e 1 !
body of read_command
begin
! tests fp command and copies names and options to command arrays
w2 call : ptr to start of command stack.
return : ptr to word after commands read.
w0,w1 return : undef. !
incode
ref return, fp_ptr;
word sw2, option_no;
text (11) list_text := "list";
text (11) survey_text := "survey";
text (11) yes_text := "yes";
text (11) no_text := "no";
begin
return := w3;
if w3 := b.output_on <> 0 then
begin
! test new line - text follows (2,10) !
if w0:=(w2).word <> w1:= 2 lshift 12 + 10 then fatal_error(.w3., w2:=2, w1:=0, w0);
! read taskname !
copy_name (.w3., w2+2, w1:=address(b.task_text));
w1 := 6; ! code for "=" !
end else w1 := 2; ! code for new line !
! test "=" / nl - text follows (-,10) !
if w0:=(w2).word <> w1 lshift 12 + 10 then fatal_error(.w3., w2:=2, w1:=0, w0);
! skip word and 'algoltask' !
w2 + 10;
! test space - text follows (4,10) !
if w0:=(w2).word <> w1:= 4 lshift 12 + 10 then fatal_error(.w3., w2:=1, w1:= 0, w0);
! copy external name !
copy_name (.w3., w2+2, w1:=address(b.ext_text));
\f
! p r o c e d u r e r e a d _ c o m m a n d p a g e 2 !
! test options (space - text follows) !
while w0:=(w2).word = w1:= 4 lshift 12 + 10 do
begin ! find option !
option_no := w3 := 1; sw2 := w2;
while w3 := option_no <= 2 do
begin
w2 := sw2;
case w3 of
begin
begin fp_ptr := w1 := address(b.no_text4); w1 := address(list_text) end;
begin fp_ptr := w1 := address(b.no_text5); w1 := address(survey_text) end;
end; ! case !
option_no := w3 + 1;
if w0:=(w2+2).word = (w1).word then
if w0:=(w2+2).word = (w1+2).word then
if w0:=(w2+2).word = (w1+2).word then
if w0:=(w2+2).word = (w1+2).word then
if w0:=(w2+2).word = w1:=8 lshift 12 + 10 ! .<text> ! then
begin
if w0:=(w2+2).word = (w1:=address(yes_text)).word then
begin if w0:=(w2+2).word = (w1+2).word then copyname (.w3., w2-2, w1:=fp_ptr) end
else
begin if w0 = (w1:=address(no_text)).word then copyname (.w3., w2, w1:=fp_ptr) end;
option_no := w0 := 1000; ! option found - stop loop !
end; ! if !
end; ! while !
! legal option found !
if w2 <> w3 := sw2 + 20 then fatal_error (.w3., w2:=1, w1:=0, w0);
end; ! while !
\f
! p r o c e d u r e r e a d _ c o m m a n d p a g e 3 !
! no more options !
if w0:=(w2).byte = 2 ! nl ! then
begin
if w3:=(w2+2).byte <> -4 then fatal_error(.w3., w2:=2, w1:=0, w0);
end
else
begin ! not nl !
if w0 <> -4 ! = end of stack ! then
begin
if w0 = -2 ! ")" ! then fatal_error(.w3., w2:=2, w1:=0, w0);
fatal_error(.w3., w2:=1, w1:=0, w0);
end;
end;
w3 := return;
end;
end;
! p r o c e d u r e r e a d _ c o m m a n d e n d !
\f
! p r o c e d u r e w r k _ n a m e s !
body of wrk_names
begin
! calls monitor to generate work file names for temporary files
and stores the names in the command arrays.
w0,w1,w2 return : undef. !
incode
ref return, start_ptr;
begin
return := w3;
start_ptr := w3 := address(b.wrk1_text1);
monitor (68); ! takes address in w3 !
if w0 <> 0 then fatal_error (.w3., w2:=0, w1:=68, w0);
copy_name (.w3., w2:=start_ptr, w1:=address(b.wrk1_text2));
start_ptr := w3 := address(b.wrk2_text1);
monitor (68);
if w0 <> 0 then fatal_error (.w3., w2:=0, w1:=68, w0);
copy_name (.w3., w2:=start_ptr, w1:=address(b.wrk2_text2));
copy_name (.w3., w2:=start_ptr, w1:=address(b.wrk2_text3));
start_ptr := w3 := address(b.wrk3_text1);
monitor (68);
if w0 <> 0 then fatal_error (.w3., w2:=0, w1:=68, w0);
copy_name (.w3., w2:=start_ptr, w1:=address(b.wrk3_text2));
w3 := return;
end;
end;
! p r o c e d u r e w r k _ n a m e s e n d !
\f
! p r o c e d u r e w r i t e _ p r g p a g e 1 !
body of write_prg
begin
! writes a file named <wrk3> consisting of an algol program
calling <wrk1>.
w0,w1,w2 return : undef. !
incode
ref return;
text (46) text1 := "begin'10' integer array ctbl(1:1), exctbl(1:1);'10'";
text (26) text2 := " calltask (ctbl, exctbl, ";
array (0:4) text3 of word;
text (7) text4 := ");'10'end'25'";
array (0:7) mess_buff of word := 0 0 0 0 0 0 0 0;
array (0:5) program_name of word;
array (0:9) tail of word := 1 1 0 0 0 0 0 0 0 0;
begin
return := w3;
! copy wrk name !
copy_name (.w3., w2:=address(b.wrk3_text1), program_name(w1:=0));
! create entry !
tail(w1:=0);
program_name(w3:=0);
monitor (40);
if w0 = 4 then fatal_error (.w3., w2:=4, w1:=40, w0);
if w0 <> 0 then fatal_error (.w3., w2:=0, w1:=40, w0);
\f
! p r o c e d u r e w r i t e _ p r g p a g e 2 !
! create area process !
monitor (52);
if w0 = 1 then fatal_error (.w3., w2:=5, w1:=52, w0);
if w0 <> 0 then fatal_error (.w3., w2:=0, w1:=52, w0);
! reserve process !
monitor (8);
if w0 <> 0 then fatal_error (.w3., w2:=0, w1:=8, w0);
! copy ext name !
copy_name (.w3., w2:=address(b.wrk1_text1), text3(w1:=0));
! write text !
mess_buff(w3:=0);
(w3).word := w1 := 5 lshift 12; ! output !
(w3+2).ref := w1 := address(text1); ! start text !
(w3+2).word := w1 + 512; ! end of text !
(w3+2).word := w1 := 0; ! segment no !
mess_buff(w1:=0);
program_name(w3:=0);
monitor (16); ! send message !
if w2 = 0 then fatal_error (.w3., w2:=3, w1:=16, w0:=0);
monitor (18); ! wait answer !
if w0 <> 1 then fatal_error (.w3., w2:=0, w1:=18, w0);
w3 := return;
end;
end;
! p r o c e d u r e w r i t e _ p r g e n d !
\f
! p r o c e d u r e n e w _ f p _ s t a c k !
body of new_fp_stack
begin
! copies the new commands from arrays to fp command stack.
w0,w1,w2 return : undef. !
incode
word stack_start, stack_end;
ref return;
begin
return := w3;
stack_end := w2 := (w3:=fp(9)).word;
! stack_start := stack_end - ( stack size + 2 ) !
w1 := address(b.start_of_commands);
w3 := address(b.end_of_commands);
stack_start := w2 - w3 + w1;
if w0 := b.output_on = 0 then
begin ! delete output file name from createtask command !
w1 := address(b.task_text) - 2; w2 := w1 + 10;
while w2 <= w3 do (w1+2).word := w0 := (w2+2).word;
w2 := stack_start + 10; w1 := address(b.start_of_commands);
end;
(w3:=fp(8)).word := w2;
! w1 = command start - 2 ! w2 - 2;
while w2 <= stack_end do (w2+2).word := w3 := (w1+2).word;
w3 := return;
end;
end;
! p r o c e d u r e n e w _ f p _ s t a c k e n d !
\f
! p r o c e d u r e c o p y _ n a m e !
body of copy_name
begin
! copies a name (4 words).
w2 call : pointer - where to read.
return : old pointer + 8.
w1 call : pointer - where to store.
return : old pointer + 8.
w0 return : undef. !
incode
ref return;
begin
return := w3;
(w1).double := f0 := (w2).double;
(w1+4).double := f0 := (w2+4).double;
w1 + 4; w2 + 4;
w3 := return;
end;
end;
! p r o c e d u r e c o p y _ n a m e e n d !
\f
! p r o c e d u r e f a t a l _ e r r o r p a g e 1 !
body of fatal_error
begin
! writes an error message and stops execution
w2 call : if > 0 error text number
w1 call : if > 0 monitor call number
w0 call : if w1 > 0 monitor call result !
incode
word error_no, mtr_call_no, result;
text (11) create_text := "'10'algoltask ";
text (26) fp1_text_1 := "- error in fp command line";
text (33) fp2_text_2 := "- compound command is not allowed";
text (23) buff_text_3 := "- buffer claim exceeded";
text (17) claim_text_4 := "- claims exceeded";
text (22) area_text_5 := "- area claims exceeded";
text (13) mtr_text := "monitor call ";
text (11) result_text := " - result =";
\f
! p r o c e d u r e f a t a l _ e r r o r p a g e 2 !
begin
error_no := w2; mtr_call_no := w1; result := w0;
write(.w3., w0:=address(create_text));
if w2 > 0 then
begin
case w2 := error_no of
begin
write (.w3., w0:=address(fp1_text_1));
write (.w3., w0:=address(fp2_text_2));
write (.w3., w0:=address(buff_text_3));
write (.w3., w0:=address(claim_text_4));
write (.w3., w0:=address(area_text_5));
end;
end;
if w1 := mtr_call_no > 0 then
begin
layout (0, 32, 2);
write(.w3., w2:=10); ! nl !
write(.w3., w0:=address(mtr_text));
write(.w3., w0:=mtr_call_no);
write(.w3., w0:=address(result_text));
write(.w3., w0:=result);
end;
write (.w3., w2:=10); write (.w3., w2:=10); ! nl !
! stop execution with ok.no warning.yes !
w2 := 3; fp(7);
end;
end;
! p r o c e d u r e f a t a l _ e r r o r e n d !
\f
! p r o c e d u r e d e b u g _ o u t p u t p a g e 1 !
body of debug_output
begin
! for debuging. writes fp commands until -4 is met.
w2 call : start pointer.
w0,w1,w2 return : undef. !
incode
byte left_byte := 0;
ref return, ptr, oldptr, startptr;
text (21) endtext := "'10''10' - end algoltask'10''10'";
text (11) spaces := " ";
begin
return := w3;
ptr := w2; oldptr := w2; left_byte := w2 := 0;
while w2:=left_byte > -4 do
begin
write (.w3., w2:=10); ! new line !
startptr := w0 := ptr;
w0 := ptr - oldptr;
write (.w3., w0); ! byte pointer !
write (.w3., w2:=46); ! point !
left_byte := w0 := byte(ptr);
write (.w3., w0); ! left byte !
write (.w3., w0:=address(spaces)); ! spaces !
ptr := w2 := ptr + 1;
w0 := byte(ptr);
write (.w3., w0); ! right byte !
write (.w3., w0:=address(spaces)); ! spaces !
w0 := byte(ptr);
ptr := w2 := ptr + 1;
\f
! p r o c e d u r e d e b u g _ o u t p u t p a g e 2 !
if w0 = 10 then
begin
write (.w3., w0:=ptr); ! text !
ptr := w2 := ptr + 8;
end
else
begin
if w0 = 4 then
begin
ptr := w2 := ptr + 1;
w0 := byte(ptr);
write (.w3., w0); ! integer !
ptr := w2 := ptr + 1;
end;
end;
end; ! of loop !;
write (.w3., w0:=address(endtext)); ! - end algoltask !
write (.w3., w2:=12); ! ff !
w3 := return;
end;
end;
! p r o c e d u r e d e b u g _ o u t p u t e n d !
\f
end. ! p r o g r a m e n d !
▶EOF◀