perm filename RESOLV.OLD[S,NET] blob
sn#794288 filedate 1985-05-27 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00018 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00003 00002 Domain name resolver program for WAITS
C00010 00003 Utility procedures
C00015 00004 Domain name representation
C00022 00005 Resource record definitions and procedures
C00036 00006 Name server records and procedures
C00043 00007 Processes and Interrupts
C00051 00008 Clock manager
C00059 00009 IP/UDP Input/Output
C00066 00010 Basic I/O procedures
C00070 00011 Input packet processing
C00084 00012 Output packet transmission
C00088 00013 Host name to Internet address translation
C00101 00014 Internet address to host name translation
C00113 00015 TTY interrupt handler
C00115 00016 MAIL interrupt handler
C00122 00017 IMP input interrupt handler
C00124 00018 Main program starts here
C00125 ENDMK
C⊗;
Comment Domain name resolver program for WAITS;
begin "resolv"
Comment To do:
> Maila, Mailb and Cname queries (define new type).
> Test TTL timeouts.
> Completion of abbreviations.
> Handle Pdl Ov, Ill Mem ref, etc.
> Don't try other addresses for a server once one works.
> Semi-intelligent ordering of server addresses to optimize expected
response time.
> Read DOMAIN.TXT[HST,NET] to initialize.
;
Comment
The resolver takes requests from other programs for domain name and
address lookups, and satisfies these by querying domain servers on other
Internet hosts. To minimize the number of queries, the program also keeps
a database (a cache) of recent information.
This program has benefitted from reading code for a Mesa domain resolver
written by Annette DeSchon at USC-ISI, and comments on the
Namedroppers@SRI-NIC mailing list, especially by Dave Mills.
Basic descriptions of the domain name system may be found in the NIC
documents RFC 882 and RFC 883. They should be read carefully before
trying to understand this program.
History (enter changes at end):
May 85 JJW Initial implementation.
end of comment;
require "{}<>" delimiters;
define ! = {comment};
! Program parameters;
define udp_retry_interval = 3*60; ! Retransmission interval in ticks;
define udp_retries = 4; ! How many before giving up;
define mail_retry_interval = 15; ! Time to wait between MAIL UUO retries;
define mail_retries = 20; ! How many before giving up;
! Network constants;
define udp_domain_port = 53; ! Well-known port for name servers;
define udp_packet_size = 128; ! Max packet size, in words;
! UUOs and job data area addresses used in assembly code;
define clkint = '717000000000;
define daycnt = '047000400100;
define exit = '047000000012;
define intorm = '047000400026;
define intacm = '047000400027;
define jobddt = '74;
define jobopc = '130;
define pjob = '047000000030;
define setddt = '047000000002;
define setnam = '047000000043;
define skpsen = '710240000000;
define srcv = '710100000000;
define timer = '047000000022;
! Process and interrupt definitions.;
require "sys:proces.def" source_file;
define intttc_inx = 2; ! Not in PROCES.DEF;
! Success codes are integer values returned by several procedures.;
define sc_success = 0; ! requested information returned;
define sc_error = 1; ! couldn't handle request;
define sc_timeout = 2; ! no reply from name server;
define sc_nomatch = 3; ! negative reply from server;
! Time-to-die values in records are represented as positive numbers in the
form [<DAYCNT date>,,<seconds since midnight>]. This allows them to be
compared as integers. The constant NEVER contains an "infinite" time
value used for records that we want never to time out.;
define never = '377777777777;
! Constants used to compute with times represented in seconds and ticks.;
define day_seconds = 24*60*60;
define half_day_ticks = 12*60*60*60;
define day_ticks = 24*60*60*60;
! Other useful macros.;
define tab = '11;
define lf = '12;
define cr = '15;
define crlf = {cr & lf};
! Global variables;
integer brk; ! Break character for string scanning;
integer current_time; ! Ticks since midnight;
integer current_daycnt; ! DAYCNT date;
integer current_rr_time; ! [<DAYCNT date>,,<seconds since midnight>];
integer our_jobnum; ! Our job number;
item chan_avail; ! Event type for free UDP channels;
item kill_request; ! Event type for reclaiming processes;
item wait_done,input_avail; ! Return items for CLOCK_WAIT;
! Break tables;
integer cmd_scan; ! For scanning TTY input commands;
Comment Utility procedures;
! ERROR prints a text message indicating an error in this program. It
should eventually be changed to write to the CTY if detached.;
simple procedure error(string mess);
begin "error"
print(mess,crlf);
end "error";
! ADDR_STR converts a 32-bit internet address to a string "a.b.c.d";
simple string procedure addr_str(integer addr);
begin "addr_str"
return(cvs(addr lsh -24) & "." &
cvs(addr lsh -16 land 255) & "." &
cvs(addr lsh -8 land 255) & "." &
cvs(addr land 255));
end "addr_str";
! ADDR_IN_STR converts a 32-bit internet address to a string "d.c.b.a.IN-ADDR";
simple string procedure addr_in_str(integer addr);
begin "addr_in_str"
return(cvs(addr land 255) & "." &
cvs(addr lsh -8 land 255) & "." &
cvs(addr lsh -16 land 255) & "." &
cvs(addr lsh -24) & ".IN-ADDR");
end "addr_in_str";
! PROMPT outputs a prompt string to the terminal.;
simple procedure prompt;
begin "prompt"
print("*");
end "prompt";
! INIT_BREAK is called once, to set up all break tables used by the program.;
simple procedure init_break;
begin "init_break"
setbreak(cmd_scan←getbreak," " & tab,null,"insk");
end "init_break";
! RELOAD_SELF is called upon receipt of a request from a user to reload the
resolver from its .DMP file.;
simple procedure reload_self;
begin "reload_self"
error("Reload feature not yet implemented.");
end "reload_self";
! LESS_TICKS compares two times in ticks, modulo midnight, so that a time
late in one day is considered less than a time early the next day.;
simple boolean procedure less_ticks(integer a,b);
begin "less_ticks"
return (0 < b-a < half_day_ticks or a-b > half_day_ticks);
end "less_ticks";
! Record class PAIR is used to hold Lisp-like list structures. Functions
CONS, CAR and CDR create and access these records. Elements of the list
must be records but may be of any record class. (SAIL has lists built-in
as part of Leap, but we don't use them.);
record_class pair (record_pointer(any_class) car_part,cdr_part);
define record_list = {record_pointer(pair)};
record_list procedure cons(record_pointer(any_class) car_part,cdr_part);
begin "cons"
record_list new_pair;
new_pair ← new_record(pair);
pair:car_part[new_pair] ← car_part;
pair:cdr_part[new_pair] ← cdr_part;
return(new_pair);
end "cons";
define car(x) = {pair:car_part[x]};
define cdr(x) = {pair:cdr_part[x]};
! REVERSE_LIST reverses the elements of a list in place.;
record_list procedure reverse_list(record_list q);
begin "reverse_list"
record_list p,r;
p ← null_record;
while q ≠ null_record do begin
r ← cdr(q);
cdr(q) ← p;
p ← q;
q ← r;
end;
return(p);
end "reverse_list";
Comment Domain name representation;
! In name server transactions, domain names are represented as sequences of
8-bit bytes, with a byte count preceding each subdomain. For example, the
domain "Foo.BAR" is represented by the sequence
(3,"F","o","o",3,"B","A","R",0)
A zero count, representing the root domain, ends the sequence. The length of
each subdomain may not be more than 63. See RFC 883 for more details.
In this program, domain names are represented as strings of 7-bit characters.
The following conventions allow an unambiguous translation between these
forms.
. separates subdomains in a domain name
\ followed by a non-digit quotes that character
\ddd represents the character with ascii code ddd (decimal)
To ensure a unique representation of domain names, "\" will only be used to
quote "." and "\", and to represent ascii codes 0 and 128..255.;
define root_domain = {".."}; ! Special representation;
! DOMAIN_TEST checks whether a string represents a valid domain name.;
simple boolean procedure domain_test(string str);
begin "domain_test"
integer char,subdomain_len,total_len;
subdomain_len ← total_len ← 0;
while length(str) do begin "test"
char ← lop(str);
if char = null then return(false); ! no nulls allowed;
subdomain_len ← subdomain_len + 1;
! This adds 1 even if CHAR ends the subdomain.;
if char = "." then begin "end of subdomain"
if subdomain_len > 64 then return(false);
total_len ← total_len + subdomain_len;
subdomain_len ← 0;
continue "test";
end "end of subdomain";
if char = "\" then begin "quote character"
integer ddd;
char ← lop(str); ! next char;
if char = null then return(false);
if char = "." or char = "\" then continue "test";
if not ("0" ≤ char ≤ "9") then return(false);
ddd ← char - "0"; ! hundreds digit;
char ← lop(str);
if char = null or not ("0" ≤ char ≤ "9") then return(false);
ddd ← ddd * 10 + char - "0"; ! tens;
char ← lop(str);
if char = null or not ("0" ≤ char ≤ "9") then return(false);
ddd ← ddd * 10 + char - "0"; ! ones;
if not (ddd = 0 or 128 ≤ ddd ≤ 255) then return(false);
end "quote character";
end "test";
if subdomain_len > 63 then return(false);
total_len ← total_len + subdomain_len + 2;
! 1 is for the subdomain just done, and 1 for the root domain.;
return (total_len < 256);
end "domain_test";
! DOMAIN_EQU tests two strings for equality, like EQU, but with
case-insensitivity.;
simple boolean procedure domain_equ(string s1,s2);
begin "domain_equ"
integer c1,c2;
while length(s1) and length(s2) do begin
c1 ← lop(s1);
c2 ← lop(s2);
if "a" ≤ c1 ≤ "z" then c1 ← c1 - '40;
if "a" ≤ c2 ≤ "z" then c2 ← c2 - '40;
if c1 ≠ c2 then return (false);
end;
return (not (length(s1) or length(s2)));
end "domain_equ";
! LOP_DOMAIN returns the first subdomain in a string, and alters the
string to be the parent domain.;
simple string procedure lop_domain(reference string domain);
begin "lop_domain"
integer char;
string subdomain;
if equ(domain,root_domain) then return(root_domain);
subdomain ← null;
while length(domain) do begin
char ← lop(domain);
if char = "." then return(subdomain);
if char = "\" then begin
subdomain ← subdomain & char;
char ← lop(domain);
! Quoted char won't be tested against ".";
end;
subdomain ← subdomain & char;
end;
! Ran off the end.;
domain ← root_domain;
return(subdomain);
end "lop_domain";
Comment Resource record definitions and procedures;
record_class rr (
integer time_to_die; ! Derived from time-to-live of record;
integer hashval; ! Computed by HASH_RR;
string name; ! Domain name;
integer type;
integer class;
integer int_data; ! Integer data (Internet address, etc.);
string str_data; ! First item of string data (usually a domain);
string str_data2; ! Second item of string data;
boolean authoritative
);
! The resource record database (cache) is a list or resource records,
sorted by the time-to-die field, which makes it easy to removed
timed-out records. If the number of records grows too large, some more
clever data structure will need to be used instead.;
record_list rr_cache;
! The following are the legal values for TYPE (taken from RFC 883): ;
define type_a = 1; ! a host address;
define type_ns = 2; ! an authoritative name server;
define type_md = 3; ! a mail destination;
define type_mf = 4; ! a mail forwarder;
define type_cname = 5; ! the canonical name for an alias;
define type_soa = 6; ! marks the start of a zone of authority;
define type_mb = 7; ! a mailbox domain name;
define type_mg = 8; ! a mail group member;
define type_mr = 9; ! a mail rename domain name;
define type_null = 10; ! a null RR;
define type_wks = 11; ! a well known service description;
define type_ptr = 12; ! a domain name pointer;
define type_hinfo = 13; ! host information;
define type_minfo = 14; ! mailbox or mail list information;
! In addition, the following may be used in queries.;
define type_axfr = 252; ! A request for a transfer of an entire zone of authority;
define type_mailb = 253; ! A request for mailbox-related records (MB, MG or MR);
define type_maila = 254; ! A request for mail agent RRs (MD and MF);
define type_all = 255; ! A request for all records;
! The following are the legal values for CLASS: ;
define class_in = 1; ! the ARPA Internet;
define class_cs = 2; ! the computer science network (CSNET);
! In addition, the following may be used in queries.;
define class_all = 255; ! any class;
! A message from or to a remote name server is represented by the following record.;
record_class message (
integer id; ! 16-bit message identifier;
boolean reply; ! TRUE if a reply;
integer opcode; ! Kind of query or reply;
boolean auth_ans; ! TRUE if an authoritative answer;
boolean truncation; ! TRUE if message was truncated;
boolean rcode; ! Response code;
record_list question; ! Question section;
record_list answer; ! Answer section;
record_list authority; ! Authority section;
record_list additional ! Additional section;
);
! The following are the legal values for OPCODE: ;
define opcode_query = 0; ! Standard query;
define opcode_iquery = 1; ! Inverse query;
define opcode_cquerym = 2; ! Completion query allowing multiple answers;
define opcode_cqueryu = 3; ! Completion query requesting a single answers;
! The following are legal values for RCODE: ;
define rcode_noerror = 0; ! No error;
define rcode_format_error = 1; ! Name server unable to interpret query;
define rcode_server_failure = 2;! Problem with name server;
define rcode_name_error = 3; ! Domain name doesn't exist;
define rcode_not_implemented = 4; ! Query type not implemented;
define rcode_refused = 5; ! Requested operation refused;
! HASH_STRING computes a hash value for strings.;
simple integer procedure hash_string(string str);
begin "hash_string"
integer h;
h ← 0;
while length(str) do h ← h rot 11 + lop(str);
return(h);
end "hash_string";
! HASH_DOMAIN works like HASH_STRING except that it forces uppercase on
all letters.;
simple integer procedure hash_domain(string str);
begin "hash_domain"
integer h,c;
h ← 0;
while length(str) do begin
c ← lop(str);
if "a" ≤ c ≤ "z" then c ← c - '40;
h ← h rot 11 + c;
end;
return(h);
end "hash_domain";
! HASH_RR computes a hash value for a resource record, used to make
equality tests more efficient, and stores it in the record.;
procedure hash_rr(record_pointer(rr) r);
begin "hash_rr"
integer hashval;
hashval ← rr:type[r] lsh 17 + rr:class[r] + hash_domain(rr:name[r]);
! The rest of the hash function depends on the RR type. This code is
interdependent with the code in INTERPRET_RDATA;
case rr:type[r] of begin "case type"
[type_cname]
[type_mb]
[type_md]
[type_mf]
[type_mg]
[type_mr]
[type_ns]
[type_ptr]
hashval ← hashval + hash_domain(rr:str_data[r]);
[type_hinfo]
[type_wks]
hashval ← hashval + hash_string(rr:str_data[r])
+ hash_string(rr:str_data2[r]);
[type_null]
[type_soa]
;
[type_a]
hashval ← hashval + rr:int_data[r]
end "case type";
rr:hashval[r] ← hashval;
end "hash_rr";
! RR_EQU tests two RRs for equality.;
define rr_equ(r1,r2) = {(rr:hashval[r1] = rr:hashval[r2] and rr_equ_test(r1,r2))};
! RR_EQU_TEST is called when two hash values are the same, to make sure the
resource records really do match.;
boolean procedure rr_equ_test(record_pointer(rr) r1,r2);
begin "rr_equ_test"
if rr:type[r1] ≠ rr:type[r2] or
rr:class[r1] ≠ rr:class[r2] or
not domain_equ(rr:name[r1],rr:name[r2]) then return(false);
! The rest of the comparison depends on the RR type. This code is
interdependent with the code in INTERPRET_RDATA;
case rr:type[r1] of begin "case type"
[type_cname]
[type_mb]
[type_md]
[type_mf]
[type_mg]
[type_mr]
[type_ns]
[type_ptr]
begin "compare str_data domains"
return(domain_equ(rr:str_data[r1],rr:str_data[r2]));
end "compare str_data domains";
[type_hinfo]
[type_wks]
begin "compare str_data and str_data2 strings"
return(equ(rr:str_data[r1],rr:str_data[r2])
and equ(rr:str_data2[r1],rr:str_data2[r2]));
end "compare str_data and str_data2 strings";
[type_minfo]
begin "compare str_data and str_data2 domains"
return(domain_equ(rr:str_data[r1],rr:str_data[r2])
and domain_equ(rr:str_data2[r1],rr:str_data2[r2]));
end "compare str_data and str_data2 domains";
[type_null]
[type_soa] return(true);
[type_a] return(rr:class[r1] = class_in and
rr:int_data[r1] = rr:int_data[r2])
end "case type";
end "rr_equ_test";
! INSERT_RR puts a new resource record into the database.;
procedure insert_rr(record_pointer(rr) r);
begin "insert_rr"
record_list p,q;
preload_with "A","NS","MD","MF","CNAME","SOA","MB","MG","MR","NULL",
"WKS","PTR","HINFO","MINFO";
own string array type_name[1:14];
print(rr:name[r]," ",type_name[rr:type[r]]," ",
(if rr:type[r] = type_a then addr_str(rr:int_data[r]) else rr:str_data[r]),
crlf);
! Don't insert records that have already expired (such as those received
with a TTL field containing 0).;
if rr:time_to_die[r] ≤ current_rr_time then return;
hash_rr(r);
! First pass checks for duplicate records.;
p ← null_record;
q ← rr_cache;
while q ≠ null_record do begin "search"
if rr_equ(r,car(q)) then begin "duplicate record"
! If new record expires before existing record, don't insert it.;
if rr:time_to_die[r] ≤ rr:time_to_die[car(q)] then return;
! Else delete the old record.;
if p = null_record then rr_cache ← cdr(q) else cdr(p) ← cdr(q);
! There should be no further duplicates, so exit loop.;
done "search";
end "duplicate record";
p ← q;
q ← cdr(q);
end "search";
! Second pass inserts new record (unless first pass returned to caller).;
p ← null_record;
q ← rr_cache;
while q ≠ null_record and rr:time_to_die[car(q)] < rr:time_to_die[r] do
begin "advance"
p ← q;
q ← cdr(q);
end "advance";
q ← cons(r,q);
if p = null_record then rr_cache ← q else cdr(p) ← q;
end "insert_rr";
! FIND_RRS returns a list of the cached resource records matching a given
specification.;
record_list procedure find_rrs(string name; integer type,class; boolean authoritative);
begin "find_rrs"
record_list p,q;
record_pointer(rr) r;
p ← null_record;
q ← rr_cache;
while q ≠ null_record do begin "check one"
r ← car(q);
if domain_equ(name,rr:name[r]) and
(type = type_all or type = rr:type[r]) and
(class = class_all or class = rr:class[r]) and
(not authoritative or rr:authoritative[r]) then
p ← cons(r,p);
q ← cdr(q);
end "check one";
return(p);
end "find_rrs";
Comment Name server records and procedures;
! Server records hold information used to communicate with name servers.
A server accessible at more than one address will have one such record
for each address.;
record_class server (
integer time_to_die; ! When to release this record;
integer hashval; ! Computed by HASH_SERVER;
string domain; ! Domain served by this server;
record_pointer(rr) addr_rr ! RR having address of this server;
);
! *** Maybe store info to allow adaptive retransmission on a per-server
*** basis.;
record_pointer(server) default_server;
record_list server_cache;
! HASH_SERVER computes a hash value for a server record and stores it in
the record.;
procedure hash_server(record_pointer(server) s);
begin "hash_server"
server:hashval[s] ← hash_domain(server:domain[s])
+ rr:hashval[server:addr_rr[s]];
end "hash_server";
! SERVER_EQU tests two server records for equality.;
define server_equ(s1,s2) = {(server:hashval[s1] = server:hashval[s2]
and domain_equ(server:domain[s1],server:domain[s2])
and rr_equ_test(server:addr_rr[s1],server:addr_rr[s2]))};
! INSERT_SERVER adds a new server record to the server cache.;
procedure insert_server(record_pointer(server) s);
begin "insert_server"
record_list p,q;
hash_server(s);
! First pass checks for duplicate records.;
p ← null_record;
q ← server_cache;
while q ≠ null_record do begin "search"
if server_equ(s,car(q)) then begin "duplicate record"
! If new record expires before existing record, don't insert it.;
if server:time_to_die[s] ≤ server:time_to_die[car(q)] then return;
! Else delete the old record.;
! *** Copy any info from old to new record before discarding.;
if p = null_record then server_cache ← cdr(q) else cdr(p) ← cdr(q);
! There should be no further duplicates, so exit loop.;
done "search";
end "duplicate record";
p ← q;
q ← cdr(q);
end "search";
! Second pass inserts new record (unless first pass returned to caller).;
p ← null_record;
q ← server_cache;
while q ≠ null_record and server:time_to_die[car(q)] < server:time_to_die[s] do
begin "advance"
p ← q;
q ← cdr(q);
end "advance";
q ← cons(s,q);
if p = null_record then server_cache ← q else cdr(p) ← q;
end "insert_server";
! FIND_SERVERS returns the list of servers appropriate to query for a
given domain name, sorted in order by their closeness in matching it.;
record_list procedure find_servers(string domain);
begin "find_servers"
record_list p,q;
! We search the server list for servers whose zones of authority match
the desired domain, then those who match the parent domain, etc. At
each stage we cons the ones we find onto the list Q, and finally we
reverse Q so that the closest matches come first.;
q ← null_record;
while domain ≠ root_domain do begin "try domain"
p ← server_cache;
while p ≠ null_record do begin "try server"
if domain_equ(domain,server:domain[car(p)]) then q ← cons(car(p),q);
p ← cdr(p);
end "try server";
lop_domain(domain);
end "try domain";
! If nothing was found, return the default server.;
if q = null_record then q ← cons(default_server,q);
return(reverse_list(q));
end "find_servers";
! INIT_SERVERS initializes the server cache.;
procedure init_servers;
begin "init_servers"
record_pointer(rr) default_rr;
! Create a permanent record for the default server.;
default_rr ← new_record(rr);
rr:name[default_rr] ← "SRI-NIC.ARPA";
rr:type[default_rr] ← type_a;
rr:class[default_rr] ← class_in;
rr:authoritative[default_rr] ← true;
rr:int_data[default_rr] ← 10 lsh 24 + 0 lsh 16 + 51; ! address 10.0.0.51;
rr:time_to_die[default_rr] ← never; ! make it permanent;
insert_rr(default_rr);
default_server ← new_record(server);
server:domain[default_server] ← root_domain;
server:addr_rr[default_server] ← default_rr;
server:time_to_die[default_server] ← never;
insert_server(default_server);
end "init_servers";
Comment Processes and Interrupts;
! This program uses the "process" feature of SAIL, which simulates concurrent
execution of multiple instruction streams. This is done to allow multiple
user requests to be in various stages of completion, and to respond to system
interrupts instead of waiting for input.
We also use the "deferred interrupt" mechanism to cause handler procedures to
be run for each of the several types of interrupts that we may deal with.
Each handler procedure should call UPDATE_TIME when it is entered.
No time-sharing between processes is done. Once a process begins or resumes
execution, it is uninterrupted until it explicitly suspends. This simplifies
a lot of the code. For instance, when a request packet is sent out, a reply
may arrive before the requester suspends to await it. But since the interrupt
handler does not handle the reply until after the requester suspends, the
requester will be correctly resumed.
Any procedure that can be entered by several instantiations of the request
processes at the same time must be declared RECURSIVE to allow its local
variables to be allocated separately for each instance.
See the SAIL reference manual for a description of the process and interrupt
facilities. (You'll be sorry you did.);
forward procedure handle_tty;
forward procedure handle_mail;
forward procedure handle_clk;
forward procedure handle_inp;
! FIX_DDT alters DDT's entry sequence to temporarily turn off TTY
interrupts, to avoid getting them when typing in to DDT or RAID.;
simple procedure fix_ddt;
quick_code "fix_ddt"
label newddt,ddtgo,ddtret,goback,save1;
skipn 1,jobddt;
popj '17,; ! return if no DDT;
hrrm 1,ddtgo; ! store existing DDT address at end of new code;
movei 1,newddt;
setddt 1,; ! store new DDT starting address;
popj '17,;
! Here when program enters DDT.;
newddt: movem 1,save1; ! borrow an AC;
movsi 1,'20000;
intacm 1,; ! turn off TTY interrupts;
move 1,jobopc;
hrrm 1,goback; ! save program return address;
movei 1,ddtret;
hrrm 1,jobopc; ! set new return address;
move 1,save1; ! restore AC;
ddtgo: jrst 0; ! go to DDT (this word patched above);
! Here when DDT returns.;
ddtret: movem 1,save1;
movsi 1,'20000;
intorm 1,; ! turn TTY interrupts back on;
move 1,save1;
goback: jrst 0; ! return (this word patched above);
save1: 0;
end "fix_ddt";
! PROCESS_RECLAIMER waits for processes to announce their termination,
and deletes the items corresponding to them so that these items can
be recycled. (Otherwise we will eventually run out of items.) This
seems like a bit of a kludge, but it's the best I could come up with.;
procedure process_reclaimer;
begin "process_reclaimer"
while true do delete(interrogate(kill_request,wait));
end "process_reclaimer";
! RECLAIM_ME is how a process asks to be deleted. Note that since
deleting a process item terminates that process (undocumented?), it
must not expect to do anything after RECLAIM_ME.;
define reclaim_me = {cause(kill_request,myproc)};
! INIT_PROCESSES sets up all the process and interrupt machinery.;
procedure init_processes;
begin "init_processes"
safe own integer array tty_block[0:1],mail_block[0:1],clk_block[0:1],
inp_block[0:1];
item intpro_item;
! CLKHAK is a procedure run at interrupt level when we get a clock
interrupt. This is needed to prevent a lot of clock interrupts
from getting queued up if the system decides not to schedule our
user level soon enough.;
simple procedure clkhak;
begin "clkhak"
start_code
clkint 0; ! Turn off clock interrupts;
end;
! Now defer interrupt as usual;
dfr1in(-2 lsh 18 + location(clk_block[0]));
end "clkhak";
fix_ddt;
! Enable interrupts and set deferred interrupt procedure locations;
tty_block[0] ← mail_block[0] ← clk_block[0] ← inp_block[0] ← 2;
tty_block[1] ← -1 lsh 18 + location(handle_tty);
mail_block[1] ← -1 lsh 18 + location(handle_mail);
clk_block[1] ← -1 lsh 18 + location(handle_clk);
inp_block[1] ← -1 lsh 18 + location(handle_inp);
intset(intpro_item,0);
intmap(inttty_inx,dfrint,-2 lsh 18 + location(tty_block[0]));
intmap(intttc_inx,prompt,0); ! Now attached, maybe;
intmap(intmail_inx,dfrint,-2 lsh 18 + location(mail_block[0]));
intmap(intclk_inx,clkhak,0);
intmap(intinp_inx,dfrint,-2 lsh 18 + location(inp_block[0]));
enable(inttty_inx);
enable(intttc_inx);
enable(intmail_inx);
enable(intclk_inx);
enable(intinp_inx);
start_code
clkint 0; ! Turn off clock interrupts till we want them;
end;
mkevtt(chan_avail); ! Declare event types;
mkevtt(kill_request);
sprout(new,process_reclaimer,priority(3));
end "init_processes";
Comment Clock manager;
! UPDATE_TIME is called whenever we get an interrupt. It stores the
current date and time of day in global variables, and removes resource
records that have timed out. All work done until the next interrupt
uses this value of the time.;
simple procedure update_time;
begin "update_time"
start_code "set globals"
label again;
daycnt 1,;
again: movem 1,current_daycnt;
timer 2,;
movem 2,current_time;
daycnt 1,; ! Make sure we aren't fooled;
came 1,current_daycnt;
jrst again; ! Go back if we were interrupted at midnight;
idivi 2,60; ! Convert time to seconds
hrli 2,(1); ! Put DAYCNT in left half;
movem 2,current_rr_time;
end "set globals";
! Remove timed-out resource and server records.;
while rr_cache ≠ null_record and
rr:time_to_die[car(rr_cache)] ≤ current_rr_time do
rr_cache ← cdr(rr_cache);
while server_cache ≠ null_record and
server:time_to_die[car(server_cache)] ≤ current_rr_time do
server_cache ← cdr(server_cache);
! Isn't garbage collection wonderful?;
end "update_time";
! Processes that are sprouted to handle requests may want to wait for a
specified number of ticks. This code handles these requests by
requesting clock interrupts at the appropriate times.;
record_class waiter (
itemvar process;
integer wake_up_time
);
! WAIT_QUEUE holds the list of clock requests, sorted in increasing order
of time.;
record_list wait_queue;
procedure init_wait_queue;
begin "init_wait_queue"
wait_queue ← null_record;
end "init_wait_queue";
! CLOCK_WAIT suspends the calling process until a given amount of time has
elapsed, or the process is resumed for some other reason. It returns the
item of the RESUME that woke up the procedure.;
recursive itemvar procedure clock_wait(integer ticks);
begin "clock_wait"
record_list p,q;
record_pointer(waiter) r;
integer time; ! Time to wake up;
integer interval;
itemvar wake_reason;
time ← current_time + ticks;
if time > day_ticks then time ← time - day_ticks;
r ← new_record(waiter);
waiter:process[r] ← myproc;
waiter:wake_up_time[r] ← time;
! print(crlf,"Process ",cvn(myproc)," should resume at ",time,crlf);
p ← null_record;
q ← wait_queue;
while q ≠ null_record and
less_ticks(waiter:wake_up_time[car(q)],time) do begin
p ← q;
q ← cdr(q);
end;
q ← cons(r,q);
if p ≠ null_record then cdr(p) ← q
else begin "new head of queue"
wait_queue ← q;
! Request a system clock interrupt, which cancels any pending
interrupt request since it is later than the one we now want.;
start_code
clkint @ticks;
end;
end "new head of queue";
! Suspend our process, and record the reason when we're reawakened.;
wake_reason ← suspend(myproc);
! When we return here, our process will have been woken, but perhaps
not by the clock. (For instance, a message might come in for us.)
We might not even exist by the time our scheduled clock interrupt
comes by, so we have to prevent it from trying to wake us. This is
done by changing the process item in the queue. (It would save
interrupts, but be hairier, to actually remove the request.);
! print("Process ",cvn(myproc)," resumed, reason ",cvn(wake_reason),crlf);
if wake_reason ≠ wait_done then waiter:process[r] ← any;
return(wake_reason);
end "clock_wait";
! HANDLE_CLK wakes up any processes that are now ready, and requests the next
clock interrupt from the system.;
procedure handle_clk;
begin "handle_clk"
record_pointer(waiter) r;
integer interval;
update_time;
! print("Clock interrupt at ",current_time,crlf);
while wait_queue ≠ null_record do begin "check waiters"
r ← car(wait_queue);
if less_ticks(current_time,waiter:wake_up_time[r]) then
done "check waiters";
! if waiter:process[r] ≠ any then
! print("HC Resuming process ",cvn(waiter:process[r]),crlf);
if waiter:process[r] ≠ any then resume(waiter:process[r],wait_done,readyme);
wait_queue ← cdr(wait_queue);
end "check waiters";
! CLKHAK has turned off clock interrupts, so we only turn them back on
if needed.;
if wait_queue ≠ null_record then begin "start the clock"
interval ← waiter:wake_up_time[car(wait_queue)] - current_time;
if interval < 0 then interval ← interval + day_ticks;
start_code
clkint @interval;
end;
end "start the clock";
end "handle_clk";
Comment IP/UDP Input/Output;
! Device IMP deals with 8-bit bytes, but the SAIL language is very heavily
oriented toward 7-bit bytes. To overcome this, we have to delve into the
internal data structures used by the I/O runtimes.
The SAIL I/O code can be found in IOSER[S,AIL] and GOGOL[S,AIL], if you
need further understanding of what is going on here.;
! SAIL defines a Channel Data Block (CDB) for each I/O channel. This includes
the OPEN block and buffer headers for the device, and other information, as
follows: ;
define dmode(cdb) = {memory[cdb+ 0]}; ! data mode;
define dname(cdb) = {memory[cdb+ 1]}; ! device;
define bfhed(cdb) = {memory[cdb+ 2]}; ! header pointers;
define obpnt(cdb) = {memory[cdb+ 3]}; ! output buffer pointer;
define obptr(cdb) = {memory[cdb+ 4]}; ! output byte pointer;
define ocownt(cdb) = {memory[cdb+ 5]}; ! output byte count;
define oname(cdb) = {memory[cdb+ 6]}; ! output file name -- for information only;
define obuf(cdb) = {memory[cdb+ 7]}; ! output buffer location;
define ibpnt(cdb) = {memory[cdb+ 8]}; ! same stuff for input;
define ibptr(cdb) = {memory[cdb+ 9]};
define icownt(cdb) = {memory[cdb+10]};
define iname(cdb) = {memory[cdb+11]};
define ibuf(cdb) = {memory[cdb+12]};
define icount(cdb) = {memory[cdb+13]}; ! input data count limit address;
define brchar(cdb) = {memory[cdb+14]}; ! xwd ttydev flag, input break char addr;
define ttydev(cdb) = {memory[cdb+14]}; ! lh -1 if device is a tty -- used by out;
define endfl(cdb) = {memory[cdb+15]}; ! input end of file flag addr;
define errtst(cdb) = {memory[cdb+16]}; ! user error bits specification word;
define linnum(cdb) = {memory[cdb+17]}; ! addr of line number word (setpl function);
define pagnum(cdb) = {memory[cdb+18]}; ! addr of page number word (setpl function);
define sosnum(cdb) = {memory[cdb+19]}; ! addr of sos number word (setpl function);
! GET_UDP_CHAN does the necessary work to set up IP/UDP communication with
the name server port on a given host. It returns the I/O channel number,
or -1 if none were available.;
simple integer procedure get_udp_chan (integer ip_addr);
begin "get_udp_chan"
integer chan,brk,eof,udpmtape,udpoutput,cdb;
safe own integer array mtape_block[0:6];
if (chan ← getchan) < 0 then return(chan);
! At least 2 output buffers are needed in order to do retransmission.;
open(chan,"imp",0,2,2,400,brk,eof);
cdb ← chncdb(chan);
dpb(8,point(6,ibptr(cdb),11)); ! Set byte size in buffer header;
dpb(8,point(6,obptr(cdb),11)); ! Set byte size in buffer header;
mtape_block[0] ← '26; ! Set UDP parameters;
mtape_block[2] ← -1; ! Gensym local port;
mtape_block[5] ← udp_domain_port; ! Domain server port;
mtape_block[6] ← ip_addr; ! Foreign host;
udpmtape ← '072000000000 + chan lsh 23 + location(mtape_block[0]);
udpoutput ← '067000000000 + chan lsh 23;
start_code
xct udpmtape; ! Set UDP parameters;
xct udpoutput; ! Initialize output buffer header;
end;
return(chan);
end "get_udp_chan";
! The array CHAN_PROC keeps track of I/O channels that are "owned" by
request-handler processes, so that we know who to wake up when input
data arrives. The item ANY is the initial value of item variables,
so this will indicate that the channel is not in use.;
safe itemvar array chan_proc[0:15]; ! Indexed by channel number;
! CLAIM_UDP_CHAN is called by a request handler process to get a UDP I/O
channel. This waits, if necessary, for a channel to become available,
using the SAIL event mechanism.;
recursive integer procedure claim_udp_chan(integer ip_addr);
begin "claim_udp_chan"
integer chan;
while true do begin "get channel"
chan ← get_udp_chan(ip_addr);
if chan < 0 then interrogate(chan_avail,wait) else done "get channel";
! Once we return from this INTERROGATE we should always get a
channel, but the loop provides additional safety.;
end "get channel";
chan_proc[chan] ← myproc;
return(chan);
end "claim_udp_chan";
! RETURN_UDP_CHAN gives back a UDP channel when done with it.;
procedure return_udp_chan(integer chan);
begin "return_udp_chan"
chan_proc[chan] ← any;
release(chan);
! Wake up any processes waiting for channels.;
cause(chan_avail,any,dontsave);
end "return_udp_chan";
Comment Basic I/O procedures;
! These procedures are passed the CDB of the I/O channel to avoid having
to call CHNCDB each time they are executed.;
! UDP_BYTE_OUT puts an 8-bit byte into the current output packet for a
channel;
simple procedure udp_byte_out (integer cdb, byte);
begin "udp_byte_out"
if (ocownt(cdb) ← ocownt(cdb)-1) ≤ 0 then
error("Packet output overflow");
idpb(byte,obptr(cdb));
end "udp_byte_out";
! UDP_WORD_OUT puts a 16-bit word into the current output packet for a
channel;
simple procedure udp_word_out (integer cdb, word);
begin "udp_word_out"
udp_byte_out(cdb,word lsh -8);
udp_byte_out(cdb,word);
end "udp_word_out";
! UDP_DOMAIN_OUT converts a domain name in our internal form into the name
server representation and puts it into the output packet. It is assumed that
the string has passed DOMAIN_TEST, so no error checking is done.;
simple procedure udp_domain_out(integer cdb; string domain);
begin "udp_domain_out"
integer char,len_byte,subdomain_len;
! LEN_BYTE will hold the byte pointer into which the length of the
current subdomain is to be stored.;
subdomain_len ← 0; ! Length so far of first subdomain;
udp_byte_out(cdb,0); ! Output length byte;
len_byte ← obptr(cdb); ! Save pointer to it;
if equ(domain,root_domain) then return; ! Root is a special case;
while length(domain) do begin "output loop"
char ← lop(domain);
if char = "." then begin "end of subdomain"
dpb(subdomain_len,len_byte);! Fix up length byte;
subdomain_len ← 0; ! Length so far of next subdomain;
udp_byte_out(cdb,0); ! Output length byte;
len_byte ← obptr(cdb); ! Save pointer to it;
continue "output loop";
end "end of subdomain";
if char = "\" then begin "quoted char"
char ← lop(domain);
if "0" ≤ char ≤ "9" then char ←
((char-"0") * 10 + lop(domain)-"0") * 10 + lop(domain)-"0";
! Now CHAR has the byte we want to output.;
end "quoted char";
udp_byte_out(cdb,char);
subdomain_len ← subdomain_len + 1;
end "output loop";
dpb(subdomain_len,len_byte); ! Length of final subdomain;
udp_byte_out(cdb,0); ! Indicate the root domain;
end "udp_domain_out";
Comment Input packet processing;
! READ_MESSAGE copies information from a UDP input packet into a message
record, and returns a pointer to that record.;
record_pointer(message) procedure read_message(integer chan);
begin "read_message"
integer udpin,input_error,cdb,word,qdcount,ancount,nscount,arcount;
own integer array packet[0:udp_packet_size-1];
record_pointer(message) m;
integer i,j,byte,save_cownt;
! The variable PTR is used by the following subroutines to step
through bytes of the input packet, and is left pointing to the
proper byte for the next data item.;
integer ptr;
define next_byte = {ildb(ptr)};
define next_word = {(next_byte lsh 8 lor next_byte)};
define next_32_bits =
{(((next_byte lsh 8 lor next_byte) lsh 8 lor next_byte) lsh 8 lor next_byte)};
! Subroutine to read a character string, represented as a length byte
followed by that many data bytes. The string is copied into a SAIL
string, using the special representation for "\" and for characters
greater than 128, but not treating "." specially.;
string procedure get_string;
begin "get_string"
integer len,byte;
string str;
str ← null;
len ← next_byte;
while len > 0 do begin
len ← len - 1;
byte ← next_byte;
if byte = "\" then str ← str & "\\"
else if byte < 128 then str ← str & byte
else str ← str & "\" &
(byte div 100 + "0") &
(byte mod 100 div 10 + "0") &
(byte mod 10 + "0");
end;
return(str);
end "get_string";
! Subroutine to read domain name, using SAIL string representation and
allowing for "pointers" (see RFC 883) in input data.;
recursive string procedure get_domain;
begin "get_domain"
string domain;
integer subdomain_len,byte,loc,save_ptr;
domain ← null;
while true do begin "subdomain loop"
subdomain_len ← next_byte;
if subdomain_len = 0 then done "subdomain loop";
if domain ≠ null then domain ← domain & ".";
if subdomain_len land '300 = '300 then begin "pointer"
loc ← (subdomain_len - '300) lsh 8 + next_byte;
save_ptr ← ptr; ! Save across recursive call;
! Compute new PTR;
ptr ← point(8,packet[0],-1);
while loc > 0 do begin ! Maybe be more clever here;
loc ← loc - 1;
ibp(ptr);
end;
domain ← domain & get_domain; ! Call ourselves;
! *** Pointers to the root domain will screw up.;
ptr ← save_ptr; ! Restore saved PTR;
done "subdomain loop";
end "pointer";
while subdomain_len > 0 do begin
subdomain_len ← subdomain_len - 1;
byte ← next_byte;
if byte = "\" or byte = "." then domain ← domain & "\" & byte
else if byte < 128 then domain ← domain & byte
else domain ← domain & "\" &
(byte div 100 + "0") &
(byte mod 100 div 10 + "0") &
(byte mod 10 + "0");
end;
end "subdomain loop";
if domain = null then domain ← root_domain;
return(domain);
end "get_domain";
! Subroutine to interpret the data portion of a resource record. Called
after type and class have been set in the RR, and data is packed in
bytes into an array. RFC 883 outlines the meaning of the data field
for each of the defined RR types. No attempt is made to ensure that
the data doesn't extend beyond the claimed length of the data field.;
procedure interpret_rdata(record_pointer(rr) r; integer rdlength);
begin "interpret_rdata"
integer byte;
case rr:type[r] of begin "case type"
[type_cname] begin "cname"
rr:str_data[r] ← get_domain; ! CNAME;
end "cname";
[type_hinfo] begin "hinfo"
rr:str_data[r] ← get_string; ! CPU;
rr:str_data2[r] ← get_string; ! OS;
end "hinfo";
[type_mb] begin "mb"
rr:str_data[r] ← get_domain; ! MADNAME;
end "mb";
[type_md] begin "md"
rr:str_data[r] ← get_domain; ! MADNAME;
end "md";
[type_mf] begin "mf"
rr:str_data[r] ← get_domain; ! MADNAME;
end "mf";
[type_mg] begin "mg"
rr:str_data[r] ← get_domain; ! MADNAME;
end "mg";
[type_minfo] begin "minfo"
rr:str_data[r] ← get_domain; ! RMAILBX;
rr:str_data2[r] ← get_domain; ! EMAILBX;
end "minfo";
[type_mr] begin "mr"
rr:str_data[r] ← get_domain; ! NEWNAME;
end "mr";
[type_null] begin "null"
! Ignore any data in NULL records;
end "null";
[type_ns] begin "ns"
rr:str_data[r] ← get_domain; ! NSDNAME;
end "ns";
[type_ptr] begin "ptr"
rr:str_data[r] ← get_domain; ! PTRDNAME;
end "ptr";
[type_soa] begin "soa"
! We don't process SOA records for now;
end "soa";
[type_a] begin "a"
if rr:class[r] = class_in then
rr:int_data[r] ← next_32_bits;
end "a";
[type_wks] begin "wks"
if rr:class[r] = class_in then begin
string bit_map;
integer mask;
rr:int_data[r] ← next_32_bits;
! To avoid extra fields in the RR just for this, we
store the protocol as a decimal string and the bit
map as a string of 0's and 1's.;
! *** Perhaps compactify the bit map more;
rr:str_data[r] ← cvd(next_word);
bit_map ← null;
rdlength ← rdlength - 6; ! Bytes so far;
while rdlength > 0 do begin
rdlength ← rdlength - 1;
byte ← next_byte;
mask ← '200;
while mask ≠ 0 do begin
bit_map ← bit_map & (if byte land mask then "1" else "0");
mask ← mask lsh -1;
end;
end;
rr:str_data2[r] ← bit_map;
end;
end "wks"
end "case type";
end "interpret_rdata";
! Subroutine to read a list of resource records. FULL is TRUE except
for the question section, where only the name, type and class fields
are read.;
record_list procedure read_rr_list(integer num; boolean full);
begin "read_rr_list"
record_list p;
record_pointer(rr) r;
integer len,save_ptr;
p ← null_record;
while num > 0 do begin "read one rr"
num ← num - 1;
r ← new_record(rr);
rr:name[r] ← get_domain;
rr:type[r] ← next_word;
rr:class[r] ← next_word;
rr:authoritative[r] ← message:auth_ans[m];
if full then begin "full record"
integer t,days;
t ← next_32_bits; ! T ← time to live in seconds;
days ← t div day_seconds; ! Divide into days and seconds;
t ← t mod day_seconds;
t ← t + (current_time div 60); ! Compute time to die;
if t > day_seconds then begin
t ← t - day_seconds;
days ← days + 1
end;
rr:time_to_die[r] ← (current_daycnt + days) lsh 18 + t;
len ← next_word;
save_ptr ← ptr; ! Save start address of RDATA field;
interpret_rdata(r,len);
ptr ← save_ptr; ! Restore PTR to start of RDATA;
while len > 0 do begin
! Now increment PTR past RDATA field. This is in case
we didn't read exactly the number of bytes specified.;
len ← len - 1;
ibp(ptr);
end;
end "full record";
p ← cons(r,p);
end "read one rr";
return(p);
end "read_rr_list";
! Beginning of code for READ_MESSAGE;
cdb ← chncdb(chan);
udpin ← '056000000000 + chan lsh 23;
start_code
setom input_error;
xct udpin; ! Skips on error;
setzm input_error;
end;
if input_error then return(null_record);
m ← new_record(message); ! Allocate record that we'll return;
save_cownt ← icownt(cdb);
! Copy bytes from input buffer to packet array.;
ptr ← point(8,packet[0],-1); ! Point to start of packet;
while icownt(cdb) > 0 do begin
icownt(cdb) ← icownt(cdb) - 1;
idpb(ildb(ibptr(cdb)),ptr);
end;
ptr ← point(8,packet[0],-1); ! Reset pointer;
ifc false thenc
print("Packet contents:" & crlf);
j ← ptr;
for i ← 1 step 1 until save_cownt do begin
byte ← ildb(j);
print(cvos(byte)," ");
if i land 3 = 0 then print(crlf);
end;
print(crlf);
endc
! Read header;
message:id[m] ← next_word;
word ← next_word;
message:reply[m] ← (word land '100000) ≠ 0;
message:opcode[m] ← word lsh -11 land '17;
message:auth_ans[m] ← (word land '2000) ≠ 0;
message:truncation[m] ← (word land '1000) ≠ 0;
message:rcode[m] ← word land '17;
qdcount ← next_word;
ancount ← next_word;
nscount ← next_word;
arcount ← next_word;
message:question[m] ← read_rr_list(qdcount,false);
message:answer[m] ← read_rr_list(ancount,true);
message:authority[m] ← read_rr_list(nscount,true);
message:additional[m] ← read_rr_list(arcount,true);
return(m);
end "read_message";
Comment Output packet transmission;
! SEND_AND_WAIT sends a packet and retransmits if necessary until a reply
is received or it decides to quit. A success code is returned.;
recursive integer procedure send_and_wait(integer chan);
begin "send_and_wait"
integer cdb,udpout,tries,save_bp,save_cownt,old_buf,new_buf;
boolean output_error;
integer i,j,byte;
cdb ← chncdb(chan);
! Save byte pointer (relative to buffer pointer) and byte count in
case we need to retransmit.;
save_bp ← obptr(cdb) - (obpnt(cdb) land '777777);
save_cownt ← ocownt(cdb);
! Construct OUT UUO for this channel.;
udpout ← '057000000000 + chan lsh 23;
ifc false thenc
print("Packet contents:" & crlf);
j ← '441000000002 + (obpnt(cdb) land '777777);
for i ← 1 step 1 until 512-save_cownt do begin
byte ← ildb(j);
print(cvos(byte)," ");
if i land 3 = 0 then print(crlf);
end;
print(crlf);
endc
for tries ← 1 step 1 until udp_retries do begin "try to send"
old_buf ← obpnt(cdb) land '777777; ! Address of buffer being sent;
print(" ⊗");
start_code
setom output_error;
xct udpout; ! Skips on error;
setzm output_error;
end;
if output_error then return(sc_error);
! Suspend our process, and see if we are resumed by a reply message.;
if clock_wait(udp_retry_interval) = input_avail then return(sc_success);
! Else assume we were woken up by WAIT_DONE (the only other possibility),
and return if we've already retransmitted enough times.;
if tries = udp_retries then done "try to send";
! To retransmit, we copy the packet from the old I/O buffer to the
current one, fix up the buffer header, and do the output again.;
new_buf ← obpnt(cdb) land '777777; ! Address of new output buffer;
arrblt(memory[new_buf+2], ! BLT Destination;
memory[old_buf+2], ! BLT Source;
memory[old_buf+1] land '777777); ! Word count;
obptr(cdb) ← save_bp + new_buf;
ocownt(cdb) ← save_cownt;
end "try to send";
! If no reply was received, return timeout error.;
print(" - no reply",crlf);
return(sc_timeout);
end "send_and_wait";
Comment Host name to Internet address translation;
! *** Much of this code is identical to what will be needed for other
*** kinds of queries. It should be separated to avoid duplication.;
! HNAME_TO_ADDRS tries to convert a domain name for a host to one or
more Internet addresses. Parameters are:
HNAME the hostname (string)
AUTHORITATIVE if non-zero, require authoritative server (boolean)
ABBREVIATED if non-zero, HNAME may be abbreviated (boolean)
MAX_ADDRS maximum number of addresses to return (integer)
ADDR_NUM actual number of addresses returned (reference integer)
ADDR_LOC first word of block to return addresses in (reference integer)
ERROR_LOC first word of block for error messages (reference integer)
The returned value is a success code.;
recursive integer procedure hname_to_addrs(string hname;
boolean authoritative,abbreviated;
integer max_addrs; reference integer addr_num,addr_loc,error_loc);
begin "hname_to_addrs"
integer chan,cdb,code;
record_list p,q,qq,servers_tried,servers_to_try;
record_pointer(rr) r;
record_pointer(server) s,s1;
record_pointer(message) m;
label restart_search;
! ERROR_STR copies an error message into the designated area.;
procedure error_str(string str);
begin "error_str"
integer c,ptr;
ptr ← point(7,error_loc,-1);
do idpb(c←lop(str),ptr) until c = 0;
end "error_str";
! CNAME_CHECK looks through a list of records for a CNAME naming the
domain in question, and alters HNAME if it finds one.;
procedure cname_check(record_list q);
begin "cname_check"
record_pointer(rr) r;
while q ≠ null_record do begin "check one"
r ← car(q);
if rr:type[r] = type_cname and domain_equ(rr:name[r],hname) then
! *** Note we don't compare class or authoritative fields.;
begin
hname ← rr:str_data[r]; ! new name;
print("--> ");
go to restart_search; ! non-local go to! ;
end;
q ← cdr(q);
end "check one";
end "cname_check";
! CHECK_RR tells whether a resource record answers the question.;
define check_rr(r) = {(
domain_equ(rr:name[r],hname) and
rr:type[r] = type_a and
rr:class[r] = class_in and
(not authoritative or rr:authoritative[r]))};
! RETURN_RR includes the information from a resource record in the reply.;
define return_rr = {
if addr_num < max_addrs then begin
memory[addr_num+location(addr_loc)] ← rr:int_data[r];
addr_num ← addr_num + 1;
end
};
! CHECK_LIST checks all the resource records in a list and includes those
that satisfy the question in the reply. It returns TRUE if any were found.;
boolean procedure check_list(record_list p);
begin "check_list"
record_pointer(rr) r;
boolean found;
found ← false;
while p ≠ null_record do begin
r ← car(p);
if check_rr(r) then begin
found ← true;
return_rr;
end;
p ← cdr(p);
end;
return(found);
end "check_list";
procedure process_normal_reply;
begin "process_normal_reply";
! *** Do some validation checking on the message;
! Add answer records to the database.;
if message:auth_ans[m] then print("-Authoritative- ");
print("Answer:",crlf);
p ← message:answer[m];
while p ≠ null_record do begin
insert_rr(car(p));
p ← cdr(p);
end;
! Add additional records to the database;
print("Additional:",crlf);
p ← message:additional[m];
while p ≠ null_record do begin
insert_rr(car(p));
p ← cdr(p);
end;
! Add authority records to the database, the server cache, and the
list of servers to try. Note that we do this after processing
the additional records since we expect them to contain the
addreses of the servers.;
print("Authority:",crlf);
p ← message:authority[m];
while p ≠ null_record do begin
r ← car(p);
insert_rr(r);
! Find all address records for this server.;
q ← find_rrs(rr:str_data[r],type_a,class_in,false);
while q ≠ null_record do begin "server address"
label no_add;
s1 ← new_record(server);
server:domain[s1] ← rr:name[r];
server:addr_rr[s1] ← car(q);
server:time_to_die[s1] ← rr:time_to_die[r];
insert_server(s1);
! If not already on the list of servers tried or to be
tried, add to list of servers to try.;
qq ← servers_tried;
while qq ≠ null_record do begin
if server_equ(s1,car(qq)) then go to no_add;
qq ← cdr(qq);
end;
qq ← servers_to_try;
while qq ≠ null_record do begin
if server_equ(s1,car(qq)) then go to no_add;
qq ← cdr(qq);
end;
servers_to_try ← cons(s1,servers_to_try);
no_add:
q ← cdr(q);
end "server address";
p ← cdr(p);
end;
end "process_normal_reply";
! Beginning of code for HNAME_TO_ADDRS;
if abbreviated then begin
error_str("Abbreviations not implemented");
return(sc_error);
end;
restart_search:
print("HNAME_TO_ADDRS for host ",hname,crlf);
addr_num ← 0;
cname_check(rr_cache);
if check_list(rr_cache) then return(sc_success);
servers_tried ← null_record;
servers_to_try ← find_servers(hname);
while servers_to_try ≠ null_record do begin "query a server"
! Get next server to try, and moved it to the tried list.;
s ← car(servers_to_try);
servers_tried ← cons(s,servers_tried);
servers_to_try ← cdr(servers_to_try);
r ← server:addr_rr[s];
print("Querying server ",rr:name[r]," at address ",addr_str(rr:int_data[r]));
! Get a UDP channel, send a query, and wait for the reply.;
chan ← claim_udp_chan(rr:int_data[r]);
cdb ← chncdb(chan);
udp_word_out(cdb,0); ! Use 0 for identifier since ports are unique.;
! *** May want to do something with identifiers;
udp_word_out(cdb,0); ! Flags word is all 0 for now.;
udp_word_out(cdb,1); ! QDcount = 1;
udp_word_out(cdb,0); ! ANcount = 0;
udp_word_out(cdb,0); ! NScount = 0;
udp_word_out(cdb,0); ! ARcount = 0;
udp_domain_out(cdb,hname); ! QNAME;
udp_word_out(cdb,type_a); ! QTYPE;
udp_word_out(cdb,class_in); ! QCLASS;
code ← send_and_wait(chan);
if code = sc_success then m ← read_message(chan);
return_udp_chan(chan); ! In any case, we're done with the channel;
case code of begin "case code"
[sc_success] begin "success"
! This means a reply was received. It doesn't necessarily
mean that the reply contains what we want yet.;
case message:rcode[m] of begin "case rcode"
[rcode_noerror] begin "no error"
process_normal_reply;
! Check the RRs in the answer section of the reply.;
if check_list(message:answer[m]) then return(sc_success);
! If no answer, look for CNAMEs in the answer section.;
cname_check(message:answer[m]);
! Might as well check the additional section as well.;
cname_check(message:additional[m]);
! If authoritative answer, no need to try other servers.;
if message:auth_ans[m] then return(sc_nomatch);
end "no error";
[rcode_format_error] begin "format error"
error_str("Name server format error");
return(sc_error);
end "format error";
[rcode_server_failure] ; ! ignore;
[rcode_name_error] begin "name error"
if message:auth_ans[m] then return(sc_nomatch);
end "name error";
[rcode_not_implemented] begin "not implemented"
error_str("Name server feature not implemented");
return(sc_error);
end "not implemented";
[rcode_refused] ! ignore;
end "case rcode";
end "success";
[sc_error] begin "error"
error_str("UDP I/O error");
return(sc_error);
end "error";
[sc_timeout] begin "timeout"
! This server didn't reply. Try next best server if any.;
end "timeout"
end "case code";
end "query a server";
return(sc_timeout); ! No one answered;
end "hname_to_addrs";
Comment Internet address to host name translation;
! ADDR_TO_HNAME tries to convert an Internet address to the official
host name of its host. Parameters are:
ADDR the address (integer)
AUTHORITATIVE if non-zero, require authoritative server (boolean)
NAME_SIZE size of name block in words (integer)
NAME_LOC first word of block to return name in (reference integer)
ERROR_LOC first word of block for error messages (reference integer)
The returned value is a success code.;
recursive integer procedure addr_to_hname(integer addr;
boolean authoritative;
integer name_size; reference integer name_loc,error_loc);
begin "addr_to_hname"
string in_addr;
integer chan,cdb,code;
record_list p,q,qq,servers_tried,servers_to_try;
record_pointer(rr) r;
record_pointer(server) s,s1;
record_pointer(message) m;
label restart_search;
! ERROR_STR copies an error message into the designated area.;
procedure error_str(string str);
begin "error_str"
integer c,ptr;
ptr ← point(7,error_loc,-1);
do idpb(c←lop(str),ptr) until c = 0;
end "error_str";
! CHECK_LIST checks all the resource records in a list. If the address
is found, it copies the host name into the reply and returns TRUE.;
boolean procedure check_list(record_list p);
begin "check_list"
record_pointer(rr) r;
string str;
integer ptr,i,c;
label return_str;
while p ≠ null_record do begin
r ← car(p);
! Two types of records to check.;
if rr:type[r] = type_a and rr:class[r] = class_in and
rr:int_data[r] = addr and
(not authoritative or rr:authoritative[r]) then begin
str ← rr:name[r];
go to return_str;
end;
if rr:type[r] = type_ptr and rr:class[r] = class_in and
domain_equ(rr:name[r],in_addr) and
(not authoritative or rr:authoritative[r]) then begin
str ← rr:str_data[r];
go to return_str;
end;
p ← cdr(p);
end;
return(false);
return_str:
ptr ← point(7,name_loc,-1);
for i ← 1 step 1 until 5*name_size-1 do begin "copy"
c ← lop(str);
if c = 0 then done "copy";
idpb(c,ptr);
end "copy";
idpb(0,ptr);
return(true);
end "check_list";
procedure process_normal_reply;
begin "process_normal_reply";
! *** Do some validation checking on the message;
! Add answer records to the database.;
if message:auth_ans[m] then print("-Authoritative- ");
print("Answer:",crlf);
p ← message:answer[m];
while p ≠ null_record do begin
insert_rr(car(p));
p ← cdr(p);
end;
! Add additional records to the database;
print("Additional:",crlf);
p ← message:additional[m];
while p ≠ null_record do begin
insert_rr(car(p));
p ← cdr(p);
end;
! Add authority records to the database, the server cache, and the
list of servers to try. Note that we do this after processing
the additional records since we expect them to contain the
addreses of the servers.;
print("Authority:",crlf);
p ← message:authority[m];
while p ≠ null_record do begin
r ← car(p);
insert_rr(r);
! Find all address records for this server.;
q ← find_rrs(rr:str_data[r],type_a,class_in,false);
while q ≠ null_record do begin "server address"
label no_add;
s1 ← new_record(server);
server:domain[s1] ← rr:name[r];
server:addr_rr[s1] ← car(q);
server:time_to_die[s1] ← rr:time_to_die[r];
insert_server(s1);
! If not already on the list of servers tried or to be
tried, add to list of servers to try.;
qq ← servers_tried;
while qq ≠ null_record do begin
if server_equ(s1,car(qq)) then go to no_add;
qq ← cdr(qq);
end;
qq ← servers_to_try;
while qq ≠ null_record do begin
if server_equ(s1,car(qq)) then go to no_add;
qq ← cdr(qq);
end;
servers_to_try ← cons(s1,servers_to_try);
no_add:
q ← cdr(q);
end "server address";
p ← cdr(p);
end;
end "process_normal_reply";
! Beginning of code for ADDR_TO_HNAME;
print("ADDR_TO_HNAME for address [",addr_str(addr),"]"&crlf);
in_addr ← addr_in_str(addr);
if check_list(rr_cache) then return(sc_success);
servers_tried ← null_record;
servers_to_try ← find_servers(in_addr);
while servers_to_try ≠ null_record do begin "query a server"
! Get next server to try, and moved it to the tried list.;
s ← car(servers_to_try);
servers_tried ← cons(s,servers_tried);
servers_to_try ← cdr(servers_to_try);
r ← server:addr_rr[s];
print("Querying server ",rr:name[r]," at address ",addr_str(rr:int_data[r]));
! Get a UDP channel, send a query, and wait for the reply.;
chan ← claim_udp_chan(rr:int_data[r]);
cdb ← chncdb(chan);
udp_word_out(cdb,0); ! Use 0 for identifier since ports are unique.;
! *** May want to do something with identifiers;
ifc false thenc
udp_word_out(cdb,0); ! Flags word is all 0 for now.;
udp_word_out(cdb,1); ! QDcount = 1;
udp_word_out(cdb,0); ! ANcount = 0;
udp_word_out(cdb,0); ! NScount = 0;
udp_word_out(cdb,0); ! ARcount = 0;
udp_domain_out(cdb,in_addr); ! QNAME;
udp_word_out(cdb,type_ptr); ! QTYPE;
udp_word_out(cdb,class_in); ! QCLASS;
elsec
! IN-ADDR queries don't seem to work yet with the NIC. Instead,
we give an inverse query.;
udp_word_out(cdb,opcode_iquery lsh 11);
udp_word_out(cdb,0); ! QDcount = 0;
udp_word_out(cdb,1); ! ANcount = 1;
udp_word_out(cdb,0); ! NScount = 0;
udp_word_out(cdb,0); ! ARcount = 0;
udp_byte_out(cdb,0); ! Dummy NAME;
udp_word_out(cdb,type_a); ! TYPE;
udp_word_out(cdb,class_in); ! CLASS;
udp_word_out(cdb,0); ! TTL (2 words);
udp_word_out(cdb,0);
udp_word_out(cdb,4); ! RDLENGTH;
udp_byte_out(cdb,addr lsh -24); ! Bytes of address;
udp_byte_out(cdb,addr lsh -16);
udp_byte_out(cdb,addr lsh -8);
udp_byte_out(cdb,addr);
endc
code ← send_and_wait(chan);
if code = sc_success then m ← read_message(chan);
return_udp_chan(chan); ! In any case, we're done with the channel;
case code of begin "case code"
[sc_success] begin "success"
! This means a reply was received. It doesn't necessarily
mean that the reply contains what we want yet.;
case message:rcode[m] of begin "case rcode"
[rcode_noerror] begin "no error"
process_normal_reply;
! Check the RRs in the answer section of the reply.;
if check_list(message:answer[m]) then return(sc_success);
! If authoritative answer, no need to try other servers.;
if message:auth_ans[m] then return(sc_nomatch);
end "no error";
[rcode_format_error] begin "format error"
error_str("Name server format error");
return(sc_error);
end "format error";
[rcode_server_failure] ; ! ignore;
[rcode_name_error] begin "name error"
if message:auth_ans[m] then return(sc_nomatch);
end "name error";
[rcode_not_implemented] begin "not implemented"
error_str("Name server feature not implemented");
return(sc_error);
end "not implemented";
[rcode_refused] ! ignore;
end "case rcode";
end "success";
[sc_error] begin "error"
error_str("UDP I/O error");
return(sc_error);
end "error";
[sc_timeout] begin "timeout"
! This server didn't reply. Try next best server if any.;
end "timeout"
end "case code";
end "query a server";
return(sc_timeout); ! No one answered;
end "addr_to_hname";
Comment TTY interrupt handler;
! Terminal input is used for a simple command language.;
procedure handle_tty;
begin "handle_tty"
string command_line;
integer command;
boolean nothing;
update_time;
command_line ← inchsl(nothing);
if nothing then return; ! False alarm (i.e., spurious interrupt);
command ← scan(command_line,cmd_scan,brk);
case command of begin "case command"
[""] ; ! Ignore empty command line;
["D"] if memory[jobddt] = 0 then print("No DDT" & crlf)
else begin "enter ddt"
label ddtret;
! We've already fixed DDT to disable and re-enable interrupts;
memory[jobopc] ← location(ddtret);
start_code
jrst @jobddt;
end;
ddtret:
print(crlf);
end "enter ddt";
["E"]["Q"] begin "exit (quit)"
start_code
seto 1,;
intacm 1,; ! Disable all interrupts;
exit;
end;
end "exit (quit)";
["I"] begin "test imp"
handle_inp;
end "test imp";
else print("Unrecognized command" & crlf)
end "case command";
prompt;
end "handle_tty";
Comment MAIL interrupt handler;
! Inter-job mail is used for requests from other programs for service.;
forward recursive procedure read_mail;
procedure handle_mail;
begin "handle_mail"
update_time;
! Sprout a new process to read the mail, and return.;
sprout(new,read_mail,pstack(3)+priority(5)+runme);
end "handle_mail";
! Definitions for the mail protocol.;
define flag_from_resolver = '1000000;
define flag_authoritative = '2000000;
define flag_abbreviated = '4000000;
define mtype_error = 1;
define mtype_timeout = 2;
define mtype_no_match = 3;
define mtype_reload = 5;
define mtype_name = 6;
define mtype_address = 7;
define mtype_mail_agent = '10;
define mtype_mailbox = '11;
! Each new message causes an instance of READ_MAIL to be sprouted. It is
declared recursive so that all of its locals are allocated separately
from other instances of the same procedure.;
internal integer debug;
recursive procedure read_mail;
begin "read_mail"
label message_sent,non_ex_job,end_read_mail;
safe integer array mail_in[0:31],mail_out[0:31],send_block[0:1];
integer jobnum,i;
! MAIL_ERROR inserts the text of an error message into the output
message, and sets the error type code.;
procedure mail_error(string mess);
begin "mail_error"
integer ptr; ! byte pointer;
ptr ← point(7,mail_out[3],-1);
while mess do idpb(lop(mess),ptr);
mail_out[1] ← flag_from_resolver + mtype_error;
end "mail_error";
! READ_MAIL code starts here.;
start_code
srcv 0,access(mail_in[0]); ! Skip if successful;
jrst end_read_mail; ! False alarm (i.e., no mail);
end;
if mail_in[0] lsh -18 ≠ cvsix(" DOM") ! Non-domain mail;
or mail_in[1] land flag_from_resolver ! Mail from another resolver;
then go to end_read_mail;
! Dispatch on message type;
case mail_in[1] land '777777 of begin "case type"
[mtype_reload] begin "reload"
reload_self;
end "reload";
[mtype_name] begin "host name to address"
string hname;
integer char,ptr; ! byte pointer;
ptr ← point(7,mail_in[3],-1);
while char ← ildb(ptr) do hname ← hname & char;
if hname = "" then mail_error("Empty host name");
case hname_to_addrs(hname,
mail_in[1] land flag_authoritative,
mail_in[1] land flag_abbreviated,
28,mail_out[3],mail_out[4],mail_out[3])
of begin "case"
[sc_success] mail_out[1] ← flag_from_resolver + mtype_name;
[sc_error] mail_out[1] ← flag_from_resolver + mtype_error;
[sc_timeout] mail_out[1] ← flag_from_resolver + mtype_timeout;
[sc_nomatch] mail_out[1] ← flag_from_resolver + mtype_no_match
end "case";
print("-----------",crlf);
end "host name to address";
[mtype_address] begin "address to host name"
integer addr;
addr ← mail_in[3];
case addr_to_hname(addr,
mail_in[1] land flag_authoritative,
29,mail_out[3],mail_out[3])
of begin "case"
[sc_success] mail_out[1] ← flag_from_resolver + mtype_address;
[sc_error] mail_out[1] ← flag_from_resolver + mtype_error;
[sc_timeout] mail_out[1] ← flag_from_resolver + mtype_timeout;
[sc_nomatch] mail_out[1] ← flag_from_resolver + mtype_no_match
end "case";
end "address to host name";
[mtype_mail_agent] begin "mail agent to address"
end "mail agent to address";
else begin "unrecognized type"
mail_error("Unrecognized message type");
end "unrecognized type"
end "case type";
! Send the reply message.;
send_block[0] ← mail_in[0] land '777777; ! Sender's job number;
send_block[1] ← location(mail_out[0]);
mail_out[0] ← '445755000000 + our_jobnum;
! mail_out[1] has already been set;
mail_out[2] ← mail_in[2] land '777777000000; ! Identifier;
for i ← 1 step 1 until mail_retries do begin "try to send"
label mailbox_full;
start_code
skpsen 0,access(send_block[0]);
jrst mailbox_full;
jrst message_sent;
jrst non_ex_job;
end;
mailbox_full:
clock_wait(mail_retry_interval); ! Wait then try again;
end "try to send";
message_sent:
non_ex_job:
end_read_mail:
reclaim_me; ! Delete process item and terminate;
end "read_mail";
Comment IMP input interrupt handler;
! HANDLE_INP wakes up processes associated with whatever channels now have IMP
input available. The processes themselves read from their channels.;
procedure handle_inp;
begin "handle_inp"
integer chan,test_mtape;
boolean avail;
update_time;
! print("IMP interrupt",crlf);
! Some IMP channel has input, but we don't know which one(s). The only
way to find out is to test all of them.;
for chan ← 0 step 1 until 15 do
if chan_proc[chan] ≠ any then begin "test channel"
test_mtape ← '072000000000 + chan lsh 23 + location('10);
start_code
setom avail;
xct test_mtape; ! Skip if input available;
setzm avail;
end;
if avail then begin "input available"
print(" !",crlf);
! Wake up process waiting for this channel.;
! print("IMP resuming process ",cvn(chan_proc[chan]),crlf);
resume(chan_proc[chan],input_avail,readyme);
end "input available";
end "test channel";
end "handle_inp";
Comment Main program starts here;
! Perform various initializations;
start_code
move 1,['736263546675]; ! '[RSLV]';
setnam 1,;
pjob 1,;
movem 1,our_jobnum;
end;
prompt;
update_time;
init_break; ! Break tables;
init_servers; ! Default name servers;
init_wait_queue;
init_processes;
! Suspend the main process, never to return again.;
suspend(myproc);
poll; ! This seems necessary, I don't know why.;
end "resolv";