Artifact fc0fd3430b2cfd946028f69f0dc34bed36d907e378056ed01800fe2988a05947:
- Executable file
r36/src/cedit.red
— part of check-in
[f2fda60abd]
at
2011-09-02 18:13:33
on branch master
— Some historical releases purely for archival purposes
git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/trunk/historical@1375 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 7097) [annotate] [blame] [check-ins using] [more...]
module cedit; % REDUCE input string editor. % Author: Anthony C. Hearn; create!-package('(cedit),'(util)); fluid '(!*mode rprifn!* rterfn!*); global '(!$eol!$ !*blanknotok!* !*eagain !*full crbuf!* crbuf1!* crbuflis!* esc!* inputbuflis!* statcounter); %esc!* := intern ascii 125; %this is system dependent and defines %a terminator for strings. symbolic procedure rplacw(u,v); if atom u or atom v then errach list('rplacw,u,v) else rplacd(rplaca(u,car v),cdr v); symbolic procedure cedit n; begin scalar x,ochan; if null terminalp() then rederr "Edit must be from a terminal"; ochan := wrs nil; if n eq 'fn then x := reversip crbuf!* else if null n then if null crbuflis!* then <<statcounter := statcounter-1; rederr "No previous entry">> else x := cdar crbuflis!* else if (x := assoc(car n,crbuflis!*)) then x := cedit0(cdr x,car n) else <<statcounter := statcounter-1; rederr list("Entry",car n,"not found")>>; crbuf!* := nil; x := for each j in x collect j; %to make a copy. terpri(); editp x; terpri(); x := cedit1 x; wrs ochan; if x eq 'failed then nil else crbuf1!* := x end; symbolic procedure cedit0(u,n); % Returns input string augmented by appropriate mode. begin scalar x; if not(x := assoc(n,inputbuflis!*)) or ((x := cadr x) eq !*mode) then return u else return append(explode x,append(cdr explode '! ,u)) end; symbolic procedure cedit1 u; begin scalar x,y,z; z := setpchar '!>; if not !*eagain then <<prin2t "For help, type ?"; !*eagain := t>>; while u and (car u eq !$eol!$) do u := cdr u; u := append(u,list '! ); %to avoid 'last char' problem. if !*full then editp u; top: x := u; %current pointer position. a: y := readch(); %current command. if y eq '!P or y eq '!p then editp x else if y eq '!I or y eq '!i then editi x else if y eq '!C or y eq '!c then editc x else if y eq '!D or y eq '!d then editd x else if y eq '!F or y eq '!f then x := editf(x,nil) else if y eq '!E or y eq '!e then <<terpri(); editp1 u; setpchar z; return u>> else if y eq '!Q or y eq '!q then <<setpchar z; return 'failed>> else if y eq '!? then edith() else if y eq '!B or y eq '!b then go to top else if y eq '!K or y eq '!k then editf(x,t) else if y eq '!S or y eq '!s then x := edits x else if y eq '! and not !*blanknotok!* or y eq '!X or y eq '!x then x := editn x else if y eq '! and !*blanknotok!* then go to a else if y eq !$eol!$ then go to a else lprim!* list(y,"Invalid editor character"); go to a end; symbolic procedure editc x; if null cdr x then lprim!* "No more characters" else rplaca(x,readch()); symbolic procedure editd x; if null cdr x then lprim!* "No more characters" else rplacw(x,cadr x . cddr x); symbolic procedure editf(x,bool); begin scalar y,z; y := cdr x; z := readch(); if null y then return <<lprim!* list(z,"Not found"); x>>; while cdr y and not(z eq car y) do y := cdr y; return if null cdr y then <<lprim!* list(z,"Not found"); x>> else if bool then rplacw(x,car y . cdr y) else y end; symbolic procedure edith; <<prin2t "THE FOLLOWING COMMANDS ARE SUPPORTED:"; prin2t " B move pointer to beginning"; prin2t " C<character> replace next character by <character>"; prin2t " D delete next character"; prin2t " E end editing and reread text"; prin2t " F<character> move pointer to next occurrence of <character>"; prin2t " I<string><escape> insert <string> in front of pointer"; prin2t " K<character> delete all chars until <character>"; prin2t " P print string from current pointer"; prin2t " Q give up with error exit"; prin2t " S<string><escape> search for first occurrence of <string>"; prin2t " positioning pointer just before it"; prin2t " <space> or X move pointer right one character"; terpri(); prin2t "ALL COMMAND SEQUENCES SHOULD BE FOLLOWED BY A CARRIAGE RETURN"; prin2t " TO BECOME EFFECTIVE">>; symbolic procedure editi x; begin scalar y,z; while (y := readch()) neq esc!* do z := y . z; rplacw(x,nconc(reversip z,car x . cdr x)) end; symbolic procedure editn x; if null cdr x then lprim!* "NO MORE CHARACTERS" else cdr x; symbolic procedure editp u; <<editp1 u; terpri()>>; symbolic procedure editp1 u; for each x in u do if x eq !$eol!$ then terpri() else prin2 x; symbolic procedure edits u; begin scalar x,y,z; x := u; while (y := readch()) neq esc!* do z := y . z; z := reversip z; a: if null x then return <<lprim!* "not found"; u>> else if edmatch(z,x) then return x; x := cdr x; go to a end; symbolic procedure edmatch(u,v); % Matches list of characters U against V. Returns rest of V if % match occurs or NIL otherwise. if null u then v else if null v then nil else if car u=car v then edmatch(cdr u,cdr v) else nil; symbolic procedure lprim!* u; <<lprim u; terpri()>>; Comment Editing Function Definitions; remprop('editdef,'stat); symbolic procedure editdef u; editdef1 car u; symbolic procedure editdef1 u; begin scalar type,x; if null(x := getd u) then return lprim list(u,"not defined") else if codep cdr x or not eqcar(cdr x,'lambda) then return lprim list(u,"cannot be edited"); type := car x; x := cdr x; if type eq 'expr then x := 'de . u . cdr x else if type eq 'fexpr then x := 'df . u . cdr x else if type eq 'macro then x := 'dm . u . cdr x else rederr list("strange function type",type); rprifn!* := 'add2buf; rterfn!* := 'addter2buf; crbuf!* := nil; x := errorset!*(list('rprint,mkquote x),t); rprifn!* := nil; rterfn!* := nil; if errorp x then return (crbuf!* := nil); crbuf!* := cedit 'fn; return nil end; symbolic procedure add2buf u; crbuf!* := u . crbuf!*; symbolic procedure addter2buf; crbuf!* := !$eol!$ . crbuf!*; put('editdef,'stat,'rlis); Comment Displaying past input expressions; put('display,'stat,'rlis); symbolic procedure display u; % Displays input stack in reverse order. % Modification to reverse list added by F. Kako. begin scalar x,w; u := car u; x := crbuflis!*; terpri(); if not numberp u then u := length x; while u>0 and x do <<w := car x . w; x := cdr x; u := u - 1>>; for each j in w do <<prin2 car j; prin2 ": "; editp cdr j; terpri()>> end; endmodule; end;