module ftr; % Various utilities for working with files and modules.
% Author: Anthony C. Hearn.
% NOTE: This module uses Standard Lisp global *RAISE as a fluid.
% This module supports several applications of file-transform.
% Currently we have:
% make-dist-files:
% module_file_split:
% downcase_file:
% trunc:
create!-package('(ftr),'(util));
fluid '(!*echo !*downcase !*upcase current!-char!* previous!-char!*
member!-channel!* old!-channel!*);
global '(!*raise charassoc!*);
global '(dir!*); % output directory name.
% global '(dirchar!*);
switch downcase,upcase;
dir!* := ""; % default.
% dirchar!* := "/";
% ***** utility functions *****.
symbolic procedure s!-match(u,v);
% Returns true if list of characters u begins with same characters
% (regardless of case) as lower case string v.
s!-match1(u,explode2 v);
symbolic procedure s!-match1(u,v);
null v
or u and (car u eq car v
or red!-uppercasep car u
and red!-char!-downcase car u eq car v)
and s!-match1(cdr u,cdr v);
symbolic procedure reverse!-chars!-to!-string u;
compress('!" . reversip('!" . u));
symbolic procedure red!-lowercasep u;
u memq '(!a !b !c !d !e !f !g !h !i !j !k !l !m !n !o !p !q !r !s
!t !u !v !w !x !y !z);
symbolic procedure red!-uppercasep u;
u memq '(!A !B !C !D !E !F !G !H !I !J !K !L !M !N !O !P !Q !R !S !T
!U !V !W !X !Y !Z);
symbolic procedure red!-char!-downcase u;
(if x then cdr x else u) where x = atsoc(u,charassoc!*);
symbolic procedure string!-upcase u;
begin scalar z;
if not stringp u then u := '!" . append(explode2 u,'(!"))
else u := explode u;
for each x in u do z := red!-char!-upcase x . z;
return compress reverse z
end;
symbolic procedure red!-char!-upcase u;
(if x then car x else u) where x = rassoc(u,charassoc!*);
% ***** functions for manipulating regular REDUCE module files *****.
symbolic procedure module_file_split u;
file!-transform(u,function module!-file!-split1);
symbolic procedure module!-file!-split1;
begin scalar x,!*raise;
while not errorp (x := errorset!*('(uread),t))
and (x := car x) neq !$eof!$
and x neq 'END!; do
if x neq 'MODULE then rerror(ftr,1,"Invalid module format")
else begin scalar ochan,oldochan,y;
y := xread t; % Should be module name.
ochan:= open(concat(dir!*,concat(mkfil y,".red")),'output);
oldochan := wrs ochan;
prin2 "module "; prin2 y; prin2 ";";
read!-module();
wrs oldochan;
close ochan
end
end;
symbolic procedure uread;
begin scalar !*raise; !*raise := t; return read() end;
symbolic procedure read!-module;
begin integer eolcount; scalar x,y;
eolcount := 0;
a: if errorp (x := errorset!*('(readch),t))
or (x := car x) = !$eof!$
or eolcount > 20
then rerror(ftr,2,"Invalid module format")
else if x = !$eol!$ then eolcount := eolcount+1
else eolcount := 0;
prin2 x;
if x memq '(!e !E)
then if y = '(L U D O M D N E)
or y = '(!l !u !d !o !m !d !n !e)
then <<prin2 readch();
terpri();
terpri();
prin2t "end;";
return nil>>
else y := list x
else if x memq '(N D M O U L !n !d !m !o !u !l)
then y := x . y
else y := nil;
go to a
end;
symbolic procedure make!-dist!-files u;
% Makes a set of distribution files from the list of packages u.
% Setting u to packages* in $rsrc/build/packages.red makes complete
% set.
for each x in u do make_dist_file x;
symbolic procedure make_dist_file x;
begin scalar !*downcase,!*echo,!*int,!*lower,msg,!*raise,ochan,
oldochan,v;
!*downcase := t;
v := concat(string!-downcase x,".red");
prin2 "Creating ";
prin2 v;
prin2t " ...";
ochan := open(mkfil v,'output);
oldochan := wrs ochan;
evload list x; % To get package list.
v := get(x,'package);
if null v then v := list x;
for each j in v do
file!-transform(module2file(j,x),function write_module);
prin2t if !*downcase then "end;" else "END;";
wrs oldochan;
close ochan
end;
symbolic procedure module2file(u,v);
% Converts the module u to a fully rooted file name with v the
% package name, assuming files exist on $rsrc followed by path
% defined by package given by associate of u in modules!*.
begin scalar x;
x := "$reduce/src/";
for each j in get(v,'path) do
% x := concat(x,concat(string!-downcase j,dirchar!*));
x := concat(x,concat(string!-downcase j,"/"));
return concat(x,concat(string!-downcase u,".red"))
end;
symbolic procedure write_module;
begin scalar x; repeat (x := write!-line nil) until x eq 'done end;
symbolic procedure write!-line bool;
begin integer countr; scalar x,y;
countr := 0;
% EOF kludge.
while (x := readline()) = "" and countr<10 do countr := countr+1;
if countr=10 then return 'done
else if countr>0 then for i:=1:countr do terpri();
y := explode2 x;
if null bool and s!-match(y,"endmodule;")
% or bool and s!-match(x,"end;")
then <<prin2t if !*upcase then string!-upcase x
else if !*downcase then string!-downcase x
else x;
if null bool then <<terpri(); terpri()>>;
return 'done>>;
x := y;
a: if null x then return terpri();
y := car x;
b: if y = '!% then return <<for each j in x do prin2 j; terpri()>>
else if y = '!"
then <<prin2 y;
x := write!-until(cdr x,'(!"))>>
else if y = '!!
then <<prin2 y;
x := cdr x;
if null x then rerror(ftr,3,"Missing character after !");
prin2 car x>>
else if s!-match(x,"comment")
then <<if !*upcase then prin2 "COMMENT" else prin2 "comment";
for j := 1:7 do x := cdr x;
x := write!-until(x,'(!; !$))>>
else if y = '! then
<<countr := 1;
while (x := cdr x) and (y := car x) = '! do
countr := countr + 1;
if null x then return terpri(); % Trailing blanks.
for i:=1:countr do prin2 " ";
go to b>>
else <<prin2 if !*upcase and red!-lowercasep y
then red!-char!-upcase y
else if !*downcase and red!-uppercasep y
then red!-char!-downcase y
else y>>;
x := cdr x;
go to a
end;
symbolic procedure write!-until(x,u);
begin scalar y;
a: if null x
then <<terpri();
x := explode2 readline(); go to a>>;
y := car x;
prin2 y;
if y memq u then return x;
x := cdr x;
go to a
end;
% ***** Converting a file to lower case *****.
symbolic procedure downcase_file u;
% Convert file named u to lower case version.
begin scalar ochan,oldochan,!*downcase,!*echo,!*int,!*raise;
prin2t "*** Output is in file 'output'";
!*downcase := t;
ochan := open("output",'output);
oldochan := wrs ochan;
file!-transform(u,function write!-file);
wrs oldochan;
close ochan
end;
symbolic procedure write!-file;
begin scalar x;
repeat (x := write!-line t) until x eq 'done end;
% ***** truncating a file to 80 characters *****.
symbolic procedure trunc u;
% Truncate a file to 80 characters.
<<lprim "output is in file 'output'";
file!-transform(u,function read!-trunc)>>;
symbolic procedure read!-trunc;
begin integer count;
scalar !*echo,!*int,!*raise,bool,ochan,oldochan,x;
oldochan := wrs (ochan := open("output",'output));
while (x := readch()) neq !$eof!$ do
if x eq !$eol!$ then <<bool := nil; count := 0; terpri()>>
else if null bool
then <<prin2 x; bool := (count := count+1)>79>>;
write oldochan;
close ochan
end;
endmodule;
end;
% The material in the rest of this file is obsolete.
% ***** Functions for manipulating files on the HP 9836 *****.
symbolic procedure merge!-9836!-files u;
% merges a list of 9836 files into a Cambridge format file v
% corresponding to a UNIX directory.
% Files are separated by the string "./ ADD NAME= <file name>.
% Last file is terminated by "./ ENDUP".
begin scalar ochan,oldochan,!*echo,!*int,!*raise;
ochan := open(mkfil u,'output);
oldochan := wrs ochan;
for each x in get(u,'file!-list) do
begin scalar y;
if null(y := get(u,'alias)) then y := u;
y := mkfilename(x,y);
prin2 "./ ADD NAME=";
if atom x then prin2t string!-upcase x
else <<prin2 string!-upcase car x;
prin2 ".";
prin2t string!-upcase cdr x>>;
file!-transform(y,function writefile)
end;
prin2t "./ ENDUP";
wrs oldochan;
close ochan
end;
symbolic procedure mkfilename(u,v);
begin
if atom u then u := u . "red";
return concat(string!-downcase v,
concat(":",concat(string!-downcase car u,
concat(".",
string!-downcase cdr u))))
end;
symbolic procedure writefile;
begin scalar countr,x;
countr := 0;
repeat
<<x := readline();
if x = "" then countr := countr+1
else <<if countr>0
then <<for i:=1:countr do terpri(); countr := 0>>;
prin2t x>>>>
until countr = 10;
end;
% ***** functions for manipulating Cambridge PDS files *****.
% To use the first function, connect to the directory where you want the
% modules written, and then say
% file!-transform("<source file>",
% function split!-cambridge!-format);
symbolic smacro procedure read!-ch(); current!-char!* := readch();
symbolic procedure split!-cambridge!-format;
% splits a file in Cambridge PDS format with ./ ADD records preceding
% each member into constituent components.
begin scalar x,!*echo,!*raise;
while not((x := read!-ch()) eq !$eof!$) do
if not previous!-char!*
then if x eq '!. and readch() eq '!/
then begin!-new!-cambridge!-member()
else rerror(ftr,4,
"File has incorrect format in first line")
else if previous!-char!* eq !$eol!$ and x eq '!.
then if read!-ch() eq '!/
then begin!-new!-cambridge!-member()
else rerror(ftr,5,
"File has unmatched period in first column")
else <<prin2 x; previous!-char!* := x>>;
close!-cambridge!-member()
end;
symbolic procedure begin!-new!-cambridge!-member;
begin scalar x,y,z;
if member!-channel!* then close!-cambridge!-member();
z := readline();
x := cdr explode z;
previous!-char!* := !$eol!$;
if not ( x := matched2(x,'(! A D D ! N A M E !=)))
then <<terpri(); prin2 "Ignoring line ./"; prin2 z; terpri();
return nil>>;
x := car x;
while cdr x do
<<y := (if red!-uppercasep car x then red!-char!-downcase car x
else if car x eq '!$ then '!@
else car x) . y;
x := cdr x>>;
y := reverse!-chars!-to!-string y;
terpri();
prin2 "Processing module "; prin2 y; prin2t " ...";
y := concat(y,".red");
member!-channel!* := open(y,'output);
old!-channel!* := wrs member!-channel!*
end;
symbolic procedure matched2(u,v);
if null v then list u
else if null u then nil
else car u eq car v and matched2(cdr u,cdr v);
symbolic procedure close!-cambridge!-member;
if not member!-channel!* then nil
else <<close member!-channel!*; wrs old!-channel!*;
member!-channel!* := old!-channel!* := nil>>;
symbolic procedure merge!-cambridge!-format(u,v);
% merges a list of files u into Cambridge PDS format file v
% with ./ ADD records preceding each member.
begin scalar ochan,oldochan,!*echo,!*raise;
ochan := open(mkfil v,'output);
oldochan := wrs ochan;
for each x in u do write!-cambridge!-member x;
prin2t "./ ENDUP";
wrs oldochan;
close ochan
end;
symbolic procedure write!-cambridge!-member u;
begin scalar y;
u := explode2 u;
for each x in u do y := red!-char!-downcase x . y;
y := concat(reverse!-chars!-to!-string y,".red"); %file name.
y := concat(dir!*,y);
prin2 "./ ADD NAME=";
if eqcar(u,'!@) then u := '!$ . cdr u;
for each x in u do prin2 x;
terpri();
file!-transform(y,function print!-cambridge!-file)
end;
symbolic procedure print!-cambridge!-file;
begin scalar x;
while not((x := readch()) eq !$eof!$) do
% if x eq '![ then prin2 string 0 % PSL dependent
% else if x eq '!] then prin2 string 4 else % PSL dependent
prin2 x
end;
% ***** and to manipulate a message from Cambridge *****.
% Note this code is PSL dependent.
symbolic procedure cambs!-msg u;
<<lprim "output is in file 'output'";
file!-transform(u,function read!-cambridge!-message)>>;
symbolic procedure read!-cambridge!-message;
begin scalar !*echo,!*int,!*raise,ochan,oldochan,x;
oldochan := wrs (ochan := open("output",'output));
while (x := readch()) neq !$eof!$ do
if x eq intern string 13 % PSL dependent
then if readch() neq intern string 11 % PSL dependent
then rerror(ftr,8,"missing ^L after ^M")
else terpri()
else prin2 x;
wrs oldochan;
close ochan
end;
% ***** functions for manipulating mfe document files *****.
symbolic procedure mfe!-6to8bit(u,v);
% converts six-bit file u into eight-bit file v.
begin scalar ochan,oldochan;
oldochan := wrs (ochan := open(v,'output));
file!-transform(u,function mfe!-6to8bit1);
wrs oldochan;
close ochan
end;
symbolic procedure mfe!-6to8bit1;
begin scalar oll,x,y;
oll := linelength 100;
while (x := readch()) neq !$eof!$ do
if x eq '!^
then if red!-uppercasep(y := readch()) then prin2 y
else if y eq '![ then '!{
else if y eq '!] then '!}
else <<prin2 x; prin2 y>>
else if x eq '!&
then if (y := readch()) eq '!& then prin2 y
else if y eq 'e
and readch() eq 'p and readch() eq 'x
then prin2 '!!
else if y eq 'v
and (y := readch()) and readch() eq 'x
then prin2 y
else if y eq 'f
and readch() eq 'u and readch() eq 'x
then prin2 '!|
else if y eq 'i then prin2 "\&i"
else rerror(ftr,9,"Invalid character after &")
else if x eq '!$ then prin2 "\$"
else if x eq '!% then prin2 "\%"
else if red!-uppercasep x then prin2 red!-char!-downcase x
else prin2 x;
linelength oll
end;
symbolic procedure mfe!-8to6bit(u,v);
% converts eight-bit file u into six-bit file v.
begin scalar ochan,oldochan;
oldochan := wrs (ochan := open(v,'output));
file!-transform(u,function mfe!-8to6bit1);
wrs oldochan;
close ochan
end;
symbolic procedure mfe!-8to6bit1;
begin scalar !*raise,oll,x;
oll := linelength 160;
while (x := readch()) neq !$eof!$ do
if x eq '!& then prin2 "&&"
else if x eq '!\ then prin2 readch()
else if x eq '!! then prin2 "&EPX"
else if x eq '!$ then prin2 "&V$X"
else if x eq '!% then prin2 "&V%X"
else if x eq '!| then prin2 "$FUX"
else if x eq '!{ then prin2 "^["
else if x eq '!} then prin2 "^]"
else if red!-uppercasep x then <<prin2 '!^; prin2 x>>
else if red!-lowercasep x then prin2 red!-char!-upcase x
else prin2 x;
linelength oll
end;