Artifact 27ec1b236bf292d7e7c6a6e4275fd9b2714d13d10a80f0d965e2ad0fa7689499:
- File
r30/cedit.red
— part of check-in
[eb17ceb7f6]
at
2020-04-21 19:40:01
on branch master
— Add Reduce 3.0 to the historical section of the archive, and some more
files relating to version sof PSL from the early 1980s. Thanks are due to
Paul McJones and Nelson Beebe for these, as well as to all the original
authors.git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/historical@5328 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 6411) [annotate] [blame] [check-ins using] [more...]
COMMENT REDUCE INPUT STRING EDITOR; GLOBAL '(CRBUF!* CRBUF1!* CRBUFLIS!* ESC!* STATCOUNTER RPRIFN!* RTERFN!* !$EOL!$ !*EAGAIN !*FULL); !*EAGAIN := NIL; %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; 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 := CDR X 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; GLOBAL '(!*BLANKNOTOK!*); 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 X 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 X; <<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,NIL); 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; BEGIN SCALAR X; U := CAR U; X := CRBUFLIS!*; TERPRI(); IF NOT NUMBERP U THEN U := LENGTH X; WHILE U>0 AND X DO <<PRIN2 CAAR X; PRIN2 ": "; EDITP CDAR X; TERPRI(); X := CDR X; U := U-1>>; END; END;