Artifact f56eb62d7f049216a6e72aed5561649869a38e33ce85f9512b127f410e952205:
- File
psl-1983/emode/emode1.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: 38951) [annotate] [blame] [check-ins using] [more...]
% % EMODE1.RED - Screen editor for PSL % % Authors: W. Galway, M. Griss, R. Armantrout % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 8 June 1982 % Copyright (c) 1982 University of Utah % % This file is the main body of code for the screen oriented editor % EMODE. This editor is patterned after EMACS from MIT and also after EM % written by Robert Armantrout for use on small Unix systems. FLUID '( Two_window_midpoint % Gives location (roughly) of dividing line for two % window mode. FirstCall % NIL means re-entering EMODE, T means first time. kill_opers % list of (names of) dispatch routines that kill % text. NEEDS MORE DOCUMENTATION! kill_buffer_ring % Vector of vectors of strings--holds recently % deleted text. kill_ring_index % Pointer to the most recent "kill buffer". last_yank_point % Vector of [buffer lineindex point], giving location % where last "yank" occured. last_operation % The "last" routine dispatched to (before the % "current operation"). runflag % EMODE continues READ/DISPATCH/REDISPLAY until NIL SelfInsertCharacter % The last character typed (dispatched on?) last_buffername % Name (a string) of the last buffer visited. !*DBG % T for debugging (not really implemented). ); FirstCall := 'T; % To force init of all structures last_buffername := "MAIN"; % Set up default, NEEDS more thought? !*DBG := NIL; % No debug % 8 entries in the kill ring. kill_buffer_ring := MkVect(7); kill_ring_index := 0; kill_opers := '( kill_line kill_region kill_forward_word kill_backward_word kill_forward_sexpr kill_backward_sexpr ); Symbolic Procedure DBG1(x); If !*DBG then Print LIST("-> ",x); Symbolic Procedure DBG2(x); If !*DBG then Print LIST("<- ",x); FLUID '(UserSetupRoutine); UserSetupRoutine := NIL; Symbolic Procedure EMODE(); % Rebind channels to use "EMODE buffers", then return. Use function % "OldFACE" to switch back to original channels. (OldFace is typically % bound to M-C-Z.) begin scalar chnl; if FirstCall then << FirstCall := NIL; % Why doesn't ALL this code go into EMODEinitialize? Sigh. EMODEinitialize(); % Any ideas where best to place the following call? % ANSWER is, GET RID OF IT, it's not a proper method to allow % customizations, since multiple users can't use it. % Current practice is for UserSetupRoutine to be a fluid--set to name % of procedure to execute inside user's initialization routine, NIL % outside of that scope. if not null UserSetupRoutine then Apply(UserSetupRoutine,NIL); % Open up special channel for buffer I/O. Arguments are % expressions to be evaluated to get name of input buffer, name of % output buffer, and a window to "pop up" for the output buffer. EmodeBufferChannel := OpenBufferChannel('CurrentBufferName, ''OUT_WINDOW, NIL ); >>; EchoOff(); !*EMODE := T; % HERE??? Set FLUID flag to show "EMODE running". % ErrorSet could be used to make sure echos get turned back on. % Use system's idea of backtrace ERRORSET('(FullRefresh), T, !*BACKTRACE); % (Need to do something if an error!) SelectEmodeChannels(); end; % Save old channels at load (compile) time? OldStdIn := STDIN!*; OldStdOut := STDOUT!*; OldErrOut := ErrOut!*; Symbolic Procedure EMODEinitialize(); % Sets up data structures for starting up EMODE. DOESN'T affect terminal % mode. begin SetScreen(); % Initialise Screen Space SetupInitialBufferStructure(); % A kludge (!?) to implement a pop-up break window. % Create the window to look into the "break" buffer. BreakWindow := FramedWindowDescriptor('BREAK, % Starts at column 39, Near top of screen Coords(39,1), % Dimensions are roughly 40 wide by 10 high. Coords(39,9)); % Very carefully (?) redefine the break handler. if FUnBoundP('pre_emode_break) then % Work with !*usermode OFF, so no objection is made as we redefine % Break. Also !*REDEFMSG OFF so that it happens "quietly". begin scalar !*USERMODE, !*REDEFMSG; CopyD('pre_emode_break,'Break); CopyD('Break, 'EMODEbreak); end; OneWindow(); % Initialize in one-window mode. end; Symbolic Procedure EMODEbreak(); % Redefined break handler for EMODE. Begin Scalar Oldwindow; Oldwindow:=CurrentWindowdescriptor; SelectWindow BreakWindow; !$BeginningOfBuffer(); % Place point at start of buffer. % Transfer control to the original break handler. Catch may be % overkill, but is more certain to catch errors and stuff. Catch(NIL, pre_emode_break() ); % When finished, "clean" our screen off. remove_current_view(); SelectWindow Oldwindow; % Back to the window we originally had. end; Symbolic Procedure OldFACE(); % Causes sytem to quit using "Rlisp Interface" mode, go back to "normal mode". << SelectOldChannels(); EchoOn(); !*EMODE := NIL; % HERE??? leave_dispatch_loop(); % Set flag to cause EMODE to exit. >>; Symbolic Procedure SelectEmodeChannels(); % Select channels that read from and write to EMODE buffers. << % Most channels just default to these? ErrOut!* is an exception, so % fix it. STDIN!* := EmodeBufferChannel; STDOUT!* := EmodeBufferChannel; ErrOut!* := EmodeBufferChannel; RDS STDIN!*; % Select the channels, "EMODE1" is called when read % routines invoke the "editor routine" for the newly % selected channels. WRS STDOUT!*; >>; Symbolic Procedure OldEMODE(); % "Old fashioned" version of invoking EMODE. "New" version invokes "Rlisp % interface" instead. This version is being kept for documentation--it's % basically obsolete. << If FirstCall then << EMODEinitialize(); FirstCall := NIL; >>; % Any ideas where best to place the following call? % Current practice is for UserSetupRoutine to be a fluid--set to name % of procedure to execute inside user's initialization routine, NIL % outside of that scope. if not null UserSetupRoutine then Apply(UserSetupRoutine,NIL); % A bit of a kludge to make sure echos get turned back on. ECHOoff(); % Do full refresh on restart, clean up junk on screen. ERRORSET('(FullRefresh), T, !*BACKTRACE); ERRORSET('(EMODE1 ""),T,!*BACKTRACE); % Use system's idea of backtrace ECHOon(); >>; Symbolic Procedure EMODE1(msg); % "msg" is an initial message to put into the "message window". begin show_message(msg); EMODEdispatchLoop(); % Execute read/dispatch/refresh loop until % "done" end; Symbolic Procedure EMODEdispatchLoop(); % Execute read/dispatch/refresh loop while fluid "runflag" is true. begin scalar runflag; runflag := T; while runflag do << % Note that it's actually a refresh/read/dispatch loop. optional_refresh(); % READ and then dispatch on character ERRORSET('(DISPATCHER),T,T); % Refresh screen (if no user input is pending). >>; PutLine(); % Make sure everything's put away! end; Symbolic Procedure FreshEMODE(); % Force Full Init << FirstCall := T; EMODE() >>; %. --------------- EMODE error handles Symbolic Procedure EMODEerror(x); Error(666," *** EMODE *** " . x); %. ---------- Buffer Management ---------- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % FLUID '( BufferNames % Buffer names are kept on the fluid association % list "BufferNames", associated with a list of % variable bindings (an "environment") for that % buffer. % Buffers are described by the following "per buffer" variables. (The % bindings of the variables depend on the current "buffer" environment.) CurrentBufferText % Vector of lines making up the buffer. % (CurrentLine is magic, see below.) CurrentBufferSize % Number of lines actually within buffer CurrentLine % The contents (text) of current line--as a linked % list of character codes. (Takes precedence over % whatever is contained in the text vector.) CurrentLineIndex % Index of "current line" within buffer. point % Number of chars to the left of point within % CurrentLine. ); % % Associated with a Buffer should be: % Its MODE (or is this WINDOW attribute?) % names of referencing windows (if any)? % Associated File (or is this WINDOW attribute?) %.------------- Basic Buffer Structure ---------------- Symbolic Procedure SetBufferText(i,text); % Store text into buffer at i. (Text is a string.) CurrentBufferText[i] := text; Symbolic Procedure GetBufferText(i); % Return the text stored in buffer at i. CurrentBufferText[i]; % Perhaps this is carrying "modularity" a bit too far? [But, I think not. % WFG] Symbolic Procedure NextIndex(i); % Put in bounds checking? i + 1; Symbolic Procedure PreviousIndex(i); i - 1; Symbolic Procedure SetupInitialBufferStructure(); % Creates initial buffers for EMODE. Should be done at loadtime? << BufferNames := NIL; % Association list of (Name . BufferDescriptor) CurrentBufferName := NIL; % Second argument does the actual work of creating the buffer. CreateBuffer('MAIN, 'create_rlisp_buffer); CreateBuffer('OUT_WINDOW, 'create_rlisp_buffer); % Not clear what the appropriate mode is, sure to change depending on % what's prompted for. CreateBuffer('PROMPT_BUFFER, 'create_rlisp_buffer); % Perhaps a "null" mode makes more sense here, but it's dangerous, % since if person edits this buffer, there's no character defined to % get out. Needs more thought (as usual)! CreateBuffer('MESSAGE_BUFFER, 'create_rlisp_buffer); % Create the BREAK (input) buffer. (I anticipate a break output % buffer one of these days.) CreateBuffer('BREAK, 'create_rlisp_buffer); % Set up the buffer text. SelectBuffer 'BREAK; % Include semicolons in the text so that both the Lisp and Rlisp % readers can handle the break buffer. Insert_string("A ;% To abort"); !$CRLF(); Insert_string("Q ;% To quit"); !$CRLF(); Insert_string("T ;% To traceback"); !$CRLF(); Insert_string("I ;% Trace interpreted stuff"); !$CRLF(); Insert_string("R ;% Retry"); !$CRLF(); Insert_string("C ;% Continue, using last value"); !$CRLF(); Insert_string("? ;% For more help"); !$CRLF(); % Start by editing in the MAIN buffer. SelectBuffer('MAIN); EstablishCurrentMode(); >>; Symbolic Procedure SelectBuffer(BufferName); % Select a buffer. (Restore its environment after saving old.) % (Some confusing subtle points have to be resolved, concerning selecting a % buffer "BufferName", where "BufferName" equals "CurrentBufferName". Current % "solution" is a kludge?) % As an example of the sort of thing that can happen--it would seem % unnecesary to restore the environment if we are selecting the % CurrentBufferName. BUT, that's not the case in the current % implementation, since (for example) the REFRESH algorithm will select a % window--which restores the "CurrentBufferName", and after selecting % window, it continues to call select the buffer. (Attempted cure for this % is to store the CurrentBufferName under some other ID in the window % environment. Ultimate cure for this is to refer to buffers, and windows, % by their values (environment association lists or whatever), rather than % by some name.) begin scalar BufferEnv; If BufferName neq CurrentBufferName then << if (BufferEnv := atsoc(BufferName,BufferNames)) then % (The environment part of (name . env) pair.) BufferEnv := cdr BufferEnv else return EMODEError list("Buffer ", BufferName, " can't be selected"); if CurrentBufferName then DeSelectBuffer CurrentBufferName; RestoreEnv BufferEnv; % Restore environment for buffer CurrentBufferName := BufferName; >>; end; Symbolic Procedure DeSelectBuffer(BufferName); begin scalar BufferEnv; if null (BufferEnv := assoc(BufferName,BufferNames)) then Return Prin2t LIST("Buffer doesn't exist to deselect:",BufferName); SaveEnv(cdr BufferEnv); % Save current buffer bindings (uses RPLACD) CurrentBufferName := NIL; end; %. ------------ Line and Char Counting ---------------- % Count lines from P1 to P2 (0 if P1 = P2). Symbolic Procedure CountLinesFrom(P1,P2); P2 - P1; % This was harder when a linked list was % used (in the past) to represent buffers. % Returns number of lines in current buffer. Symbolic Procedure CountAllLines; CurrentBufferSize; % Returns number of lines from current line (inclusive) to end of buffer. Symbolic Procedure CountLinesLeft; CurrentBufferSize - CurrentLineIndex; % Returns number of lines before the current line. Symbolic Procedure CountLinesBefore; CurrentLineIndex; % zero origin indexing % -----------CHARACTER Lines (line contents)--------- % Some lines are currently represented as a linked list of ASCII characters . % Insert SelfInsertCharacter into the current line, update point. Symbolic Procedure InsertSelfCharacter(); InsertCharacter SelfInsertCharacter; Symbolic Procedure InsertCharacter(ch); << if ch = char EOL then !$CRLF() else << CurrentLine := InsertListEntry(CurrentLine,Point,ch); Point := Point + 1; >>; >>; Symbolic Procedure transpose_characters(); % Transpose the last two characters, if we're at the end of the line, or if % a character was just inserted. Otherwise, transpose the characters on % either side of point. begin scalar ch1, ch2; if point = length CurrentLine OR last_operation eq 'InsertSelfCharacter then !$BackwardCharacter(); % Gripe if not enough to the left. (??) if point < 1 then return Ding(); ch2 := CurrentCharacter(); !$BackwardCharacter(); ch1 := CurrentCharacter(); DeleteCharacter(); DeleteCharacter(); InsertCharacter(ch2); InsertCharacter(ch1); end; Symbolic Procedure AppendLine(contents, PreviousLine); % Append line with "contents" just past "PreviousLine" begin integer putindx; CurrentBufferSize := CurrentBufferSize + 1; % Grow the buffer if necessary. if CurrentBufferSize > size(CurrentBufferText) then CurrentBufferText := concat(CurrentBufferText, MkVect(63)); putindx := CurrentBufferSize - 1; % Shuffle from the back while putindx > PreviousLine + 1 do << SetBufferText(putindx, GetBufferText(putindx - 1)); putindx := putindx - 1; >>; % Put new line just past "PreviousLine". SetBufferText(putindx, contents); end; Symbolic Procedure Insert_string(strng); % Insert a string into the buffer, starting at point, update point to be % just past string. begin scalar newline; PutLine(); % Pack the current line in (as a string) newline := GetBufferText(CurrentLineIndex); % Grab it back. newline := nary!-concat( sub(newline,0,point-1), % head of old string strng, % new string % and tail of old string. sub(newline, point, size(newline) - point) ); % Update point point := point + size(strng) + 1; % Put away the new line SetBufferText(CurrentLineIndex, newline); GetLine(CurrentLineIndex); % Get it back (I know, wierd!) end; Procedure append_line(s); % Append string as a new line in the current buffer. << !$CRLF(); insert_string(s); >>; Symbolic Procedure InsertLine(linetext); % Insert line before current line, then position past newly inserted line. % (An efficiency crock?) % "linetext" is a linked list of character codes (for now). << !$BeginningOfLine(); !$CRLF(); !$BackwardLine(); CurrentLine := linetext; PutLine(); !$ForwardLine(); >>; Symbolic Procedure insert_kill_buffer(); % Insert the "kill_buffer" into the current location (i.e. "yank"). Record % location of "point" after the yank, so that unkill_previous can avoid % doing stuff if not at the last yank point. % (This code isn't very efficient, it's an order(M*N) algorithm, when it % should really be order(N)--should be reworked.) begin scalar kill_buffer; % Avoid doing anything if kill_buffer not set up. kill_buffer := kill_buffer_ring[kill_ring_index]; if kill_buffer then << SetMark(); PutLine(); Insert_string(kill_buffer[0]); if size(kill_buffer) > 0 then << GetLine(CurrentLineIndex); !$CRLF(); !$BackwardLine(); for i := 1 : size(kill_buffer) - 1 do << AppendLine(kill_buffer[i], CurrentLineIndex); CurrentLineIndex := NextIndex(CurrentLineIndex); >>; CurrentLineIndex := NextIndex(CurrentLineIndex); GetLine(CurrentLineIndex); % KLUDGE! point := 0; % More kludge Insert_string(kill_buffer[size(kill_buffer)]); >>; GetLine(CurrentLineIndex); >>; % Note precise location of this yank, create the pointer if NIL. if null last_yank_point then last_yank_point := MkVect(2); last_yank_point[0] := CurrentBufferName; last_yank_point[1] := CurrentLineIndex; last_yank_point[2] := point; end; Symbolic Procedure unkill_previous(); % Delete (without saving away) the current region, and then unkill (yank) % the "previous" entry in the kill ring. "Ding" if not at location of last % yank. if null last_yank_point OR not(CurrentBufferName eq last_yank_point[0]) OR not(CurrentLineIndex equal last_yank_point[1]) OR not(point equal last_yank_point[2]) then Ding() else << Delete_or_copy(T, CurrentLineIndex, point, MarkLineIndex, MarkPoint); rotate_kill_index(-1); insert_kill_buffer(); >>; Symbolic Procedure InsertListEntry(oldlist,pos,val); % Insert val into oldlist at position pos (or at end of list if pos too big) if null oldlist then list(val) else if pos = 0 then cons( val , oldlist ) else cons( car oldlist , InsertListEntry( cdr oldlist , pos-1 , val )); % Delete character at point in current line Symbolic Procedure DeleteCharacter(); CurrentLine := DeleteListEntry(CurrentLine,Point); % Delete list entry at pos (or do nothing if pos past end of list) Symbolic Procedure DeleteListEntry(oldlist,pos); if null oldlist then NIL else if pos = 0 then cdr oldlist else cons(car oldlist, DeleteListEntry(cdr oldlist , pos-1 )); % Return character at point in current line. Symbolic Procedure CurrentCharacter(); begin scalar linetail; linetail := Tail(CurrentLine,point); return if null linetail then char EOL else car linetail; end; % Return first n entries at head of x. Symbolic Procedure Head(x,n); if null x then NIL else if n = 0 then NIL else cons(car x , Head(cdr x,n-1)); Symbolic Procedure PackLine(lst); % Pack a list of character codes into a string. List2String lst; Symbolic Procedure UnpackLine(str); % Unpack a string, or NIL, into a list of character codes. if null str then NIL % SPECIAL CASE else String2List str; Symbolic Procedure PutLine(); % Put away the magical current line (may want to check for necessity?) SetBufferText(CurrentLineIndex, PackLine CurrentLine); Symbolic Procedure GetLine(x); % "UNPACK" line pointed to by x << CurrentLine := UnpackLine GetBufferText(x); CurrentLineIndex := x; >>; Symbolic Procedure SelectLine(x); % Select a new current line at location x. if (x neq CurrentLineIndex) then % If a non-trivial operation << PutLine(); % Put away the old line GetLine(x); % and fetch the new one. >>; Symbolic Procedure delete_or_copy(del_flg, line1,point1, line2, point2); % Delete (if del_flg is non-NIL) or copy (otherwise) the text between % line1, point1 (column) through line2, point2, inclusive. Return the % deleted (or copied) text as a pair of ((direction_of_deletion) . % (vector_of_strings)). The "direction" is +1 if (line1, point1) <= % (line2, point2), and -1 otherwise. Update (CurrentLineIndex, point) if % it lies within the deleted region. begin scalar deleted_text,dir , text_length, indx, tmp, tmp2; PutLine(); dir := 1; % Default % Make sure that (line1, point1) comes first. if line2 < line1 then << dir := -1; tmp := line2; line2 := line1; line1 := tmp; tmp := point2; point2 := point1; point1 := tmp; >> else if (line1 = line2) and (point2 < point1) then << dir := -1; tmp := point2; point2 := point1; point1 := tmp; >>; % Update (CurrentLineIndex, point), if it lies in deleted region. if del_flg and ((line1 < CurrentLineIndex) or ((line1 = CurrentLineIndex) and (point1 < point))) and ((CurrentLineIndex < line2) or ((CurrentLineIndex = line2) and (point <= point2))) then << CurrentLineIndex := line1; point := point1; >>; % Similarly for "mark". (A kludge, this should at least be a macro.) if del_flg and ((line1 < MarkLineIndex) or ((line1 = MarkLineIndex) and (point1 < MarkPoint))) and ((MarkLineIndex < line2) or ((MarkLineIndex = line2) and (MarkPoint <= point2))) then << MarkLineIndex := line1; MarkPoint := point1; >>; % Get length of deleted text, in lines, suitable for 0 indexing (i.e. 0 % is "length" for one line of text). text_length := line2 - line1; deleted_text := MkVect(text_length); tmp := GetBufferText(line1); % Grab first line of region to delete. % Things are simple if deletion all on the same line. if text_length = 0 then << if del_flg then SetBufferText(line1, concat(sub(tmp, 0, point1-1), sub(tmp, point2, size(tmp) - point2))); % Refetch "current line". GetLine(CurrentLineIndex); deleted_text[0] := sub(tmp, point1, point2-point1-1); return dir . deleted_text; >>; % deleted_text[0] gets everything on line1 to the right of point1, and % the new line gets everything to the left (with more to be tacked on % later). deleted_text[0] := sub(tmp, point1, size(tmp) - point1); % Store away the deleted part of the last line of the region. tmp2 := GetBufferText(line2); deleted_text[text_length] := sub(tmp2, 0, point2-1); % and tack the tail onto the head of undeleted line1. if del_flg then SetBufferText(line1, concat(sub(tmp, 0, point1 - 1), sub(tmp2, point2, size(tmp2)-point2))); % Copy rest of text into deleted_text. for i := line1+1 : line2-1 do deleted_text[i-line1] := GetBufferText(i); % Shuffle all the text, deleting the lines between line1 and line2. if del_flg then << indx := 1; while not EndOfBufferP(line2+indx) do << SetBufferText(line1+indx, GetBufferText(line2 + indx)); indx := indx + 1; >>; % Note size change (but don't bother to decrease the actual size of the % vector holding the text, for now). CurrentBufferSize := CurrentBufferSize - (line2 - line1); >>; % Refetch "current line". GetLine(CurrentLineIndex); return dir . deleted_text; end; Symbolic Procedure DeleteTextEntry(x); % Delete the line at x (delete entry from vector of lines). % Depends on CurrentLine being "put away". << if not EndOfBufferP(x) then << x := x+1; % Shuffle the elements down one entry. while not EndOfBufferP(x) do << SetBufferText(x-1, GetBufferText(x)); x := x+1; >>; CurrentBufferSize := CurrentBufferSize - 1; % Note size change % (But don't bother to decrease actual size of line vector.) >>; GetLine(CurrentLineIndex); >>; %. ------------- Basic Dispatch Callable Control Procedures Symbolic Procedure leave_dispatch_loop(); % Set flag to cause exit from read/dispatch/refresh loop. << PutLine(); % Make sure current line "put away". runflag := NIL; % (Set flag to be detected by "main loop".) >>; Symbolic Procedure !$DeleteBuffer(); % Delete entire contents of buffer (similar to creating new buffer) << % Initial vector allows only one line. (Should really be parameterized.) CurrentBufferText := MkVect(1); CurrentBufferSize := 1; % Start with one line of text (but % zero characters in the line!) CurrentLine := NIL; CurrentLineIndex := 0; point := 0; >>; % Move to beginning of buffer Symbolic Procedure !$BeginningOfBuffer(); << SelectLine(0); point := 0; >>; % Move to end of buffer Symbolic Procedure !$EndOfBuffer(); << SelectLine(CurrentBufferSize - 1); point := length(CurrentLine); >>; Symbolic Procedure SetMark(); % Set "mark" pointer from "point". << MarkLineIndex := CurrentLineIndex; MarkPoint := point; >>; Symbolic Procedure ExchangePointAndMark(); begin scalar tmp; tmp := point; point := MarkPoint; MarkPoint := tmp; tmp := CurrentLineIndex; % NOTE, it doesn't work to just set % CurrentLineIndex := MarkLineIndex. SelectLine(MarkLineIndex); MarkLineIndex := tmp; end; % NOTE, there is a vague asymmetry about EndOfBufferP and % BeginningOfBufferP. These folks need more thought to avoid off by one % errors. (Should work in terms of characters, not lines?) Symbolic Procedure EndOfBufferP(i); % Return T if i is at end of buffer (past the last line in the buffer). i >= CurrentBufferSize; Symbolic Procedure BeginningOfBufferP(i); % Return T if i at beginning (first line) of buffer. i <= 0; % Use <= for robustness % Insert a CRLF at point (new line character (or end of line character % if you prefer)) Symbolic Procedure !$CRLF(); << % Store away the head of the current line (at the current line) SetBufferText(CurrentLineIndex , PackLine Head(CurrentLine,Point) ); % Append the tail end of the line just past the current line, and point % to it. CurrentLine := Tail(CurrentLine,Point); AppendLine(PackLine CurrentLine , CurrentLineIndex); CurrentLineIndex := NextIndex(CurrentLineIndex); Point := 0; >>; % Move to beginning of current line Symbolic Procedure !$BeginningOfLine(); Point := 0; % Move to end of current line Symbolic Procedure !$EndOfLine(); Point := length(CurrentLine); % Move up a line (attempting to stay in same column), dont move past; % start of buffer:= Symbolic Procedure !$BackwardLine(); if BeginningOfBufferP(CurrentLineIndex) then Ding() else << SelectLine(PreviousIndex(CurrentLineIndex)); if Point > Length CurrentLine then Point := Length(CurrentLine) >>; Symbolic Procedure !$ForwardLine(); % Move down a line (attempting to stay in same column), don't move past % end of buffer. if EndOfBufferP(NextIndex CurrentLineIndex) then Ding() else << SelectLine(NextIndex CurrentLineIndex); % DO WE REALLY want to change point? WFG If point > Length(CurrentLine) then point := Length CurrentLine >>; % Move back a character, to previous line if at start of current line. Symbolic Procedure !$BackwardCharacter(); if point = 0 then if BeginningOfBufferP(CurrentLineIndex) then Ding() else << SelectLine(PreviousIndex(CurrentLineIndex)); point := Length(CurrentLine); >> else point := point - 1; % Move forward a character, to Next line if at end of current line. Symbolic Procedure !$ForwardCharacter(); % NOTE use of "length" function, assumption of list for CurrentLine. if point = length(Currentline) then if EndOfBufferP(NextIndex CurrentLineIndex) then Ding() else << SelectLine(NextIndex(CurrentLineIndex)); Point := 0; >> else point := point+1; % Delete character before point. Symbolic Procedure !$DeleteBackwardCharacter(); << if point = 0 and BeginningOfBufferP(CurrentLineIndex) then Ding() else << !$BackwardCharacter(); !$DeleteForwardCharacter(); >>; >>; % Delete character after point Symbolic Procedure !$DeleteForwardCharacter(); if point = length(Currentline) then if EndOfBufferP(CurrentLineIndex) or % Complain if at (or near) EndOfBufferP(NextIndex CurrentLineIndex) % end of buffer. then Ding() else << % non-destructively append Next line to this line CurrentLine := Append(CurrentLine, UnpackLine GetBufferText(NextIndex(CurrentLineIndex))); PutLine(); DeleteTextEntry NextIndex CurrentLineIndex; >> else DeleteCharacter(); Symbolic Procedure rotate_kill_index(N); % Step the kill_ring_index by N, modulo the ring size. begin scalar ring_size; kill_ring_index := kill_ring_index + N; % Now do "cheap and dirty" modulus function. % Get number of entries in ring, compensate for 0 indexing. ring_size := size(kill_buffer_ring) +1; while kill_ring_index >= ring_size do kill_ring_index := kill_ring_index - ring_size; while kill_ring_index < 0 do kill_ring_index := kill_ring_index + ring_size; end; Symbolic Procedure update_kill_buffer(killed_text); % Update the "kill buffer", either appending/prepending to the current % buffer, or "pushing" the kill ring, as appropriate. killed_text is a % pair, the car of which is +1 if the text was "forward killed", and -1 if % "backwards killed". The cdr is the actual text (a vector of strings). begin scalar new_entry, tmp, tmp1, tmp2; % If last operation wasn't a kill, then "push" the new text. if not (last_operation memq kill_opers) then << rotate_kill_index(1); % Move to a new kill buffer. kill_buffer_ring[kill_ring_index] := cdr killed_text; >> else % Otherwise, append or prepend the text, as appropriate. << tmp1 := kill_buffer_ring[kill_ring_index]; % The old text. tmp2 := cdr killed_text; % The new text to tack on. % Swap the two pieces of text if deletion was "backwards". if car killed_text < 0 then << tmp := tmp1; tmp1 := tmp2; tmp2 := tmp; >>; % Allocate space for the new "kill buffer". (A bit tricky due to 0 % indexing and fact that the last line of tmp1 is concatenated with % first line of tmp2.) new_entry := MkVect(size(tmp1) + size(tmp2)); tmp := 0; % Now tmp serves as index into the new buffer. for i := 0 : size(tmp1) - 1 do << new_entry[tmp] := tmp1[i]; tmp := tmp + 1; >>; % Concatenate last line of tmp1 with first line of tmp2. new_entry[tmp] := concat(tmp1[size tmp1], tmp2[0]); tmp := tmp + 1; % Tack on the rest of tmp2. for i := 1 : size(tmp2) do << new_entry[tmp] := tmp2[i]; tmp := tmp + 1; >>; kill_buffer_ring[kill_ring_index] := new_entry; >>; end; Symbolic Procedure kill_region(); % Kill (and save in kill buffer) the region between point and mark. << update_kill_buffer delete_or_copy(T, CurrentLineIndex, point, MarkLineIndex, MarkPoint); >>; Symbolic Procedure copy_region(); % (Should this be counted as a "kill_oper"? How about previous kills?) << update_kill_buffer delete_or_copy(NIL, CurrentLineIndex, point, MarkLineIndex, MarkPoint); >>; % Kill current line from point onwards, or delete "CRLF" if at end of line. Symbolic Procedure kill_line(); begin scalar cline, cpoint; cline := CurrentLineIndex; cpoint := point; % Move over region to kill, then kill it. if point = length(CurrentLine) then % Delete CRLF at end of line. !$ForwardCharacter() % (Skip over CRLF.) else !$EndOfLine(); update_kill_buffer delete_or_copy(T, cline, cpoint, CurrentLineIndex, point); end; Symbolic Procedure kill_forward_word(); begin scalar cline, cpoint; cline := CurrentLineIndex; cpoint := point; % Move over region to kill, then kill it. forward_word(); update_kill_buffer delete_or_copy(T, cline, cpoint, CurrentLineIndex, point); end; Symbolic Procedure kill_backward_word(); begin scalar cline, cpoint; cline := CurrentLineIndex; cpoint := point; % Move over region to kill, then kill it. backward_word(); update_kill_buffer delete_or_copy(T, cline, cpoint, CurrentLineIndex, point); end; Symbolic Procedure kill_forward_sexpr(); begin scalar cline, cpoint; cline := CurrentLineIndex; cpoint := point; % Move over region to kill, then kill it. forward_sexpr(); update_kill_buffer delete_or_copy(T, cline, cpoint, CurrentLineIndex, point); end; Symbolic Procedure kill_backward_sexpr(); begin scalar cline, cpoint; cline := CurrentLineIndex; cpoint := point; % Move over region to kill, then kill it. backward_sexpr(); update_kill_buffer delete_or_copy(T, cline, cpoint, CurrentLineIndex, point); end; %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Symbolic Procedure Print1Dispatch(ch1, ch2, fname); % Print out the dispatch routine for a (possibly "extended") character. % (Second "character" is NIL for unextended characters.) % Don't print anything if it's a self inserting character, or "undefined". << if not(fname memq '(InsertSelfCharacter Ding)) then PrintF("%w %w %w%n", character_name ch1, character_name ch2, fname); >>; Symbolic Procedure PrintAllDispatch; % Print out the current dispatch table. % Need a "mode" that dumps stuff in a form appropriate for SCRIBE? << % First, list the routines bound to single characters. for ch := 0:255 do Print1Dispatch(ch, NIL, getv(MainDispatch, ch)); % next, list all the C-X bindings for each x in cdr atsoc(char cntrl X, PrefixAssociationLists) do Print1Dispatch(char cntrl X, car x, cdr x); >>; Symbolic Procedure GetInternalName(ch,DispatchTable); if pairp DispatchTable then if(ch := atsoc(ch,DispatchTable)) then cdr ch else 'Ding else getv(DispatchTable,ch); fluid '(character_name_table); % An association list of (character code . name), used by procedure % character_name. character_name_table := '( (8#7 . "Bell") (8#10 . "Backspace") (8#11 . "Tab") (8#12 . "Linefeed") (8#15 . "Return") (8#33 . "Escape") (8#40 . "Blank") (8#177 . "Rubout") ); Symbolic Procedure character_name(ch); % Return a string giving the name for a character code, return "" if "ch" % not a number. Names for control characters are typically "C-...", names % for meta characters are "M-...". Printing characters name themselves. begin scalar name; % Typically ch will be NIL if it isn't a number. if not numberp ch then return ""; name := MkString(0,0); % A one character string if ch > char BLANK and ch <= char '!~ then name[0] := ch % A "printing" character else if LAND(ch, 8#200) neq 0 then % Meta bit set name := concat("M-", character_name LAND(ch,8#177)) else if name := atsoc(ch, character_name_table) then name := cdr name % association list catches wild cards. else if ch < char BLANK then name := concat("C-", if ch = 8#37 then character_name(char RUBOUT) else character_name(ch + 8#100)) else EMODEerror list(ch, " is bad character code for routine `character_name'"); return name; end; Symbolic Procedure !$HelpDispatch(); % Give a little information on the routine bound to a keyboard character % (or characters, in the case of prefixed things). % We need to do a better job of merging this code with PrintAllDispatch, % AND the code that actually dispatches. begin scalar ch1, ch2, fname; ch1 := prompt_for_character("Function of character: "); if ch1 = char ESC then % Treat as meta character << ch1 := LOR( 8#200, GetNextCommandCharacter()); fname := GetInternalName(ch1, MainDispatch) >> else if ch1 = char meta X OR ch1 = char cntrl X then << ch2 := GetNextCommandCharacter(); fname := GetInternalName(ch2,atsoc(ch1, PrefixAssociationLists)) >> else fname := GetInternalName(ch1,MainDispatch); show_message BldMsg("%w %w %w", character_name ch1, character_name ch2, fname); end; %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Symbolic Procedure OpenLine(); % Insert a NEWLINE (or EOL) at POINT, keep POINT before newline << InsertCharacter(char EOL); !$BackwardCharacter(); >>;