module cedit; % REDUCE input string editor. % Author: Anthony C. Hearn; create!-package('(cedit),'(util)); fluid '(!*mode); global '(!$eol!$ !*blanknotok!* !*eagain !*full crbuf!* crbuf1!* crbuflis!* esc!* inputbuflis!* rprifn!* rterfn!* 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 <> else x := cdar crbuflis!* else if (x := assoc(car n,crbuflis!*)) then x := cedit0(cdr x,car n) else <>; 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 <>; 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 <> else if y eq 'q or y eq '!q then <> 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 <>; while cdr y and not z eq car y do y := cdr y; return if null cdr y then <> else if bool then rplacw(x,car y . cdr y) else y end; symbolic procedure edith; < replace next character by "; prin2t " D delete next character"; prin2t " E end editing and reread text"; prin2t " F move pointer to next occurrence of "; prin2t " I insert in front of pointer"; prin2t " K delete all chars until "; prin2t " P print string from current pointer"; prin2t " Q give up with error exit"; prin2t " S search for first occurrence of "; prin2t " positioning pointer just before it"; prin2t " 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; <>; 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 <> 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; <>; 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 <>; for each j in w do <> end; endmodule; end;