|
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: 9984 (0x2700) Types: TextFile Names: »tapdtejob«
└─⟦a41ae585a⟧ Bits:30001842 SW-save af projekt 1000, Alarm-system └─⟦72244f0ef⟧ └─⟦this⟧ »tapdtejob«
job oer 3 200 time 11 0 area 10 size 100000 ( source = copy 25.1 tapdtelst = set 1 disc1 tapdteerr = set 1 disc1 tapdtelst = indent source mark lc listc = cross tapdtelst o tapdteerr message tapdte program pascal80 spacing.3000 codesize.3000 alarmenv paxenv source o c lookup pass6code if ok.yes ( tapdtebin = set 1 disc1 tapdtebin = move pass6code scope user tapdtebin ) tapdtelst = copy listc errors scope user tapdtelst scope user tapdteerr finis output.no ) \f process tapdte ( opsem : sempointer; (* operator sem *) var sem : !ts_pointer ); (* main sem *) (*--------------------------------------------------------------- * * function: the tapdte module is used to supervise * the traffic to netconnector * * externals: testopen, testout * * var params: sem * * semaphores: the module sends to the system semaphore * "operatorsem". --------------------------------------------------------------*) const version = "vers 0.01 /" ; \f const opbufsize = 80; (* no. of bytes in buffers to the operator module *) firstindex= 6 + alfalength; lastindex= firstindex + (opbufsize - 1); ok= 0; (* result from operator *) type opbuftype= record first, last, next: integer; name: alfa; data: array (firstindex..lastindex) of char end; alarmbuftype = array (1..size_listen) of integer; alfa10= array (1..10) of char; var (********* pools *********) opbufpool: pool 3 of opbuftype; (********** semaphores **********) wsem (* buffers written by the operatormodule is returned here *) : semaphore; (********** references **********) opoutref, (* ref. to buffer to operator *) cur (* ref. to current buffer *) : reference; (********** zones **********) z: zone; (********** integers **********) base, (* number base for input and output *) mc, i, lastword (* used by "o"-command *) : integer; (********** externals **********) procedure setoflowmask ( obit: boolean); external; \f procedure outchar(ch:char); (* writes ch into the output buffer *) begin lock opoutref as opbuf: opbuftype do with opbuf do begin last:= last + 1; data (last):= ch; end; end (* outchar *); \f procedure outinteger ( int, positions : integer); (* writes the integer int using outchar *) type digittable = array (0..15) of char; const lastpos = 16; (* lastpos+1 positions in layout *) dig = digittable ('0','1','2','3','4','5','6','7', '8','9','a','b','c','d','e','f' ); type range = 0..lastpos ; var digits : array (range) of char; p : range; res : integer; negative : boolean; procedure setzero ( stop : range ); (* global p *) begin while p > stop do begin res:= 0; digits(p):= '0'; p:= p-1 end; if base = 16 then digits(p+1):= dig(8+res) else digits(p+1):= '1' end; begin for p:= 0 to lastpos do digits(p):= sp; p:= lastpos; negative:= int<0; if negative and (base <> 10 ) then int:= int - (-32768); repeat (* unpack the digits backwards *) res:= abs ( int mod base); digits(p):= dig(res); p:= p-1; int:= int div base until (p=0) or (int=0); if negative then case base of 2: setzero ( lastpos-16); 8: setzero ( lastpos-6); 10: begin digits(p):= '-'; (* sign *) p:= p-1 end; 16: setzero ( lastpos-4) otherwise end; (* case *) res:= lastpos+1 - positions; (* where to start *) while res < 0 do (* make extra sp *) begin outchar ( sp); res:= res+1 end; if res < p then p:= res; for p:= p to lastpos do outchar ( digits(p)); end; (* outinteger *) \f procedure outstring10(text: alfa10); (* writes the text into opbuf starting at outputpointer which is updated accordingly *) var i: integer; begin for i:=1 to 10 do outchar( text(i) ); end (* out string 10 *); \f procedure outnl; (* prepares opbuf for output to the operator and signals it to operator module *) begin if not nil(opoutref) then begin outchar(nl); signal(opoutref, opsem^) end; wait(opoutref, wsem); lock opoutref as opbuf: opbuftype do opbuf.last:= firstindex; end (* writenl *); \f procedure alarmdisplay( alarm:max_alarm_mess); var i,j : integer; begin for i := 0 to 1 do begin for j := 1 to 16 do outinteger( alarm(16*i +j), 4); outnl; end; end; procedure write_rut_prefix(p:rut_prefix_type); begin with p do begin outstring10("first "); outinteger(first, 6); outnl; outstring10("last "); outinteger( last, 6); outnl; outstring10("next "); outinteger( next, 6); outnl; outstring10("ext-no "); outinteger(ext_no,6); outnl; end end; \f (* write_ext_pax_adr write_int_pax_adr write_rut_header write_alarmlabel write_control write_paxnet_e *) \f procedure call_buf_display( call_buf : call_field_type); var i : integer; begin with call_buf do begin outstring10("dte-adr-l "); outinteger( dte_adr_l, 6); outnl; outstring10("dte-adr "); for i := 1 to 14 do outinteger( dte_adr(i), 2); outnl; outstring10("facility-l"); outinteger( facility_l,6); outnl; outstring10("facilities"); outinteger( facility, 6); outnl; outstring10("control "); outchar(":"); outnl; with control do begin outstring10("op-code "); outinteger( op_code, 6); outnl; outstring10("data "); outinteger( data , 6); outnl; outstring10("n-s-inc "); outinteger( n_s_inc, 6); outnl; outstring10("n-s "); outinteger( n_s, 6); outnl; outstring10("n-r-inc "); outinteger( n_r_inc, 6); outnl; outstring10("n-r "); outinteger( n_r, 6); outnl; end; alarmdisplay( alarm_mess); end; end; \f procedure dtedisplay; begin outchar("u"); outchar(":"); case cur^.u1 of dte_car : outstring10("dte-car "); dte_clr : outstring10("dte-clr "); dte_ric : outstring10("dte-ric "); dte_rdata : outstring10("dte-rdata "); dte_sdata : outstring10("dte-sdata "); dte_aic : outstring10("dte-aic "); dte_rejic : outstring10("dte-rejic "); otherwise outinteger (cur^.u1, 6); end; outinteger( cur^.u2, 4); outinteger( cur^.u3, 4); outinteger( cur^.u4, 4); outnl; case cur^.u1 of dte_car : lock cur as buf : car_buf_type do with buf do begin outstring10("first "); outinteger(first , 6); outnl; outstring10("last "); outinteger(last , 6); outnl; outstring10("next "); outinteger(next , 6); outnl; outstring10("q-bit "); if q_bit then outstring10("true ") else outstring10("false "); outnl; call_buf_display( call_buf); end; dte_clr : lock cur as buf : clear_buf_type do with buf do begin outstring10("diag-code "); outinteger( diag_code, 4); outnl; end; dte_ric : begin end; dte_rdata : begin end; otherwise begin end; end; end; \f procedure display; begin outchar ("u"); outchar(":"); outinteger ( cur^.u1, 4); outinteger ( cur^.u2, 4); outinteger ( cur^.u3, 4); outinteger ( cur^.u4, 4); outinteger ( cur^.size, 8); outnl; if cur^.size >= size_listen then (* alarmbuffer *) lock cur as buf: alarmbuftype do if buf(1) in (. 0..64 .) then begin outstring10 ("label "); for i:= 1 to 8 do outinteger ( buf(i), 6); outnl; lastword:= (buf(1)+3) div 2; if lastword > size_listen then lastword:= size_listen; if lastword > 8 then begin outstring10 ("datapart "); for i:= 9 to lastword do outinteger ( buf(i), 6); outnl; end end end; (* display *) \f procedure rutdisplay; begin outchar("u"); outchar(":"); case cur^.u1 of rut_con : outstring10("rut-con "); rut_trp : outstring10("rut-trp "); rut_dir : outstring10("rut-dir "); rut_rec : outstring10("rut-rec "); rut_stat: outstring10("rut-stat "); otherwise outinteger( cur^.u1, 6); end; outinteger( cur^.u2, 4); outinteger( cur^.u3, 4); outinteger( cur^.u4, 4); outnl; case cur^.u1 of rut_con : lock cur as buf : rut_prefix_type do with buf do begin outstring10("extension "); outinteger( ext_no, 6); outnl; end; rut_trp : lock cur as buf : rut_trp_pdata do begin write_rut_prefix( buf.rut_prefix); end; otherwise begin end end; display; end; \f function equal ( a, b : sempointer ): boolean; type os = record sp: sempointer end; var one, two: os; begin one.sp:= a; two.sp:= b; equal:= one = two end; \f (**************************************** * * * m a i n p r o g r a m * * * ****************************************) begin testopen (z, own.incname, opsem); testout ( z, version, al_env_version); (* initialise op buffers *) for i:= 1 to 3 do begin alloc (opoutref, opbufpool, wsem); opoutref^.u1:=2; (* write *) lock opoutref as opbuf: opbuftype do with opbuf do begin first:= firstindex; name:= own.incname; data(firstindex):= "!"; end; return (opoutref); end; outnl; setoflowmask ( true); (* no except for arith. overflow *) base:= 16; repeat wait ( cur, sem.w^); if cur^.u4 = from_link then rutdisplay else if cur^.u4 = to_link then dtedisplay else display; if equal ( sem.w, sem.s ) then return ( cur) else signal ( cur, sem.s^) until false end . ▶EOF◀