⟦55e564f7e⟧

TextFile

{$F+,O+}\r
unit rtp86rmx;\r
interface\r
uses pscplm;\r
(*******************************************)\r
(* Real Time Pascal - rmx86 interface      *)\r
(* contains all rmx86 dependent functions  *)\r
(* 84.01.08                            EDM *)\r
(*******************************************)\r
const\r
     table_length=1024;\r
\r
type\r
\r
     string_table=array[0..table_length] of byte;\r
\r
\r
(****** ROUTINES ******)\r
procedure init_argument;\r
(* must be called before other use *)\r
\r
function insert_key(a:string):byte;\r
(* if accepted the key number is returned *)\r
(* else 0 is returned                     *)\r
\r
function get_argument(var s:string;var key:byte;var e:word):byte;\r
(* if accepted ( e=0 ) the delimeter is returned, *)\r
(* s is the next argument and                     *)\r
(* key is the arguments key number if the argument*)\r
(* is a key else 0                                *)\r
\r
procedure change_ext(var s,d:string;a:string);\r
(* d is returned as s with new extention a *)\r
(* if s is device (last char is ':') no change *)\r
\r
function file_exist(path:string):boolean;\r
(* if error trying to connect path true is returned *)\r
\r
implementation\r
const\r
\r
\r
(*rmx exceptioncodes*)\r
e_ok = 0;\r
e_nfexist = 33; (*file does not exist*)\r
\r
\r
var key_table:string_table;\r
\r
type\r
paramptr = ^paramheap;\r
paramheap = record\r
  parameter : string;\r
  next      : paramptr;\r
end;\r
var\r
  call_line_ptr : paramptr;\r
\r
procedure init_argument;\r
var i:integer;\r
    line_ptr :paramptr;\r
    f : text;\r
    str : string;\r
begin\r
  key_table[0]:=0;\r
  new(call_line_ptr);\r
  call_line_ptr^.next := nil;\r
  call_line_ptr^.parameter:='';\r
  line_ptr := call_line_ptr;\r
  for i:=1 to paramcount do\r
    begin\r
      str := paramstr(i);\r
      if str[1] <> '-' then\r
      line_ptr^.parameter :=concat(line_ptr^.parameter, paramstr(i),' ')\r
      else\r
        begin\r
          delete(str,1,1);\r
          (*str := concat(str,'.RCI');*)\r
          if file_exist(str) then\r
          begin\r
            assign(f,str);\r
            reset(f);\r
            while not eof(f) do\r
              begin\r
               new(line_ptr^.next);\r
               line_ptr := line_ptr^.next;\r
               line_ptr^.next := nil;\r
               readln(f,line_ptr^.parameter);\r
               insert(' ',line_ptr^.parameter,length(line_ptr^.parameter) + 1);\r
              end;\r
            close(f);\r
            new(line_ptr^.next);\r
            line_ptr := line_ptr^.next;\r
            line_ptr^.next := nil;\r
            line_ptr^.parameter := ' ';\r
          end\r
          else\r
            begin\r
              writeln;\r
              writeln('THE PARAMETER FILE: ',str,' DOES NOT EXIST');\r
              halt;\r
            end;\r
        end;\r
    end;\r
  line_ptr^.parameter:=concat(line_ptr^.parameter,chr(13));\r
  line_ptr := Call_line_ptr;\r
  while line_ptr <> nil do\r
  begin\r
  for i:=1 to length(line_ptr^.parameter) do\r
     line_ptr^.parameter[i]:=upcase(line_ptr^.parameter[i]);\r
  line_ptr := line_ptr^.next;\r
  end;\r
end;\r
\r
\r
function find_key(var s:string):byte;\r
var no,pos,i:integer;\r
    found:boolean;\r
begin\r
  no:=0;\r
  pos:=1;\r
  found:=false;\r
  while (no<key_table[0]) and not found and (pos+length(s)<=table_length) do\r
  begin\r
    no:=no+1;\r
    found:=true;\r
    for i:=0 to length(s) do found:=found and (ord(s[i])=key_table[i+pos]);\r
    pos:=pos+key_table[pos]+1;\r
  end;\r
  if found then find_key:=no\r
           else find_key:=0;\r
end;\r
\r
function insert_key(a:string):byte;\r
var pos,i:integer;\r
begin\r
  pos:=1;\r
  i:=1;\r
  while (pos<=table_length) and (i<=key_table[0]) do\r
  begin\r
    pos:=pos+key_table[pos]+1;\r
    i:=i+1;\r
  end;\r
  if (key_table[0]=254) or (pos+length(a)+1>table_length)\r
  then insert_key:=255\r
  else begin\r
         key_table[pos]:=length(a);\r
         for i:=1 to length(a) do key_table[pos+i]:=ord(a[i]);\r
         key_table[0]:=key_table[0]+1;\r
         insert_key:=key_table[0];\r
       end;\r
end;\r
\r
function delimitor(ch: char):boolean;\r
begin\r
  delimitor:= (ch=' ') or (ch='(') or (ch=')') or (ch=',') or (ch='=')\r
  or (ch=chr(13));\r
end;\r
\r
\r
function get_argument(var s:string;var key:byte;var e:word):byte;\r
const e_ok=0;\r
var s_p, l, i:integer;\r
    ch:char;\r
    ptr : paramptr;\r
begin\r
  if length(call_line_ptr^.parameter) = 0 then\r
   begin\r
     ptr := call_line_ptr;\r
     call_line_ptr := ptr^.next;\r
     dispose(ptr);\r
   end;\r
  e:=e_ok;\r
  s_p:=0;\r
  repeat\r
    s_p:=s_p+1;\r
    ch:=call_line_ptr^.parameter[s_p];\r
  until ch<>' ';\r
  l:= 0;\r
  while not delimitor(ch) do\r
  begin l:=l+1; ch:=call_line_ptr^.parameter[s_p+l]; end;\r
  i:=s_p+l;\r
  while (ch=' ') and (i < length(Call_line_ptr^.Parameter)) do\r
    begin i:=i+1; ch:=call_line_ptr^.parameter[i] end;\r
  if ch<>chr(13) then\r
  if delimitor(ch) then i:=i+1 else ch:=' ';\r
  s:= copy(call_line_ptr^.parameter, s_p, l);\r
  call_line_ptr^.parameter:= copy(call_line_ptr^.parameter, i, 255);\r
  get_argument:= ord(ch);\r
  key:=find_key(s);\r
  if call_line_ptr^.parameter = ' ' then call_line_ptr^.parameter := '';\r
(*  writeln('getargument: ',s,key:10,'   "',ch,'"');*)\r
end;\r
\r
procedure change_ext(var s,d:string;a:string);\r
var pos,i:integer;\r
begin\r
  pos:=length(s)+1;\r
  for i:=1 to pos-1 do if s[i]='.' then pos:=i;\r
  d:= s;\r
  delete(d, pos + 1, 255);\r
  d:= concat(d, a)\r
end;\r
\r
\r
function file_exist(path:string):boolean;\r
var f:text;\r
    i:integer;\r
begin\r
  (*$I-*)\r
  assign(f, path);\r
  reset(f);\r
  (*$I-*)\r
  i:= ioresult;\r
  if i=0 then close(f);\r
  file_exist:= (i=0) or ( i = 5);\r
end;\r
\r
begin\r
end.\r
«eof»
DataMuseum.dk

DANOSI

⟦55e564f7e⟧ TextFile

Derivation

TextFile
