Artifact 09b53f9f662dc5150936fb6d2bbf48ffcfe5c5860d6a36329d3e73fba42e9fbf:

• File psl-1983/emode/customize-rlisp-for-emode.sl — 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: 4757) [annotate] [blame] [check-ins using] [more...]

%
% CUSTOMIZE-RLISP-FOR-EMODE.SL - "customizations" to support EMODE.
% 
% Author:      William F. Galway
%              Symbolic Computation Group
%              Computer Science Dept.
%              University of Utah
% Date:        14 July 1982
% Copyright (c) 1982 University of Utah
%

% This file makes a few changes to the "innards" of RLISP to customize it
% for the building of EMODE.  Also adds a few utilities that should
% (perhaps) become part of the standard PSL.

% Set things up so SETF knows about IGETV and IGETS.  ("Fast" string and
% vector accessors.)
(BothTimes       % BothTimes?
  (progn
    (put 'IGETV 'ASSIGN-OP 'IPUTV)
    (put 'IGETS 'ASSIGN-OP 'IPUTS)))

% Return true  is x is a "list".  (I.e., a pair or NIL.)
(de listp (x)
  (or (null x) (pairp x)))

% Return lst with its first n entries dropped.
(de tail (lst n)
  (cond
    ((null lst) NIL)
    ((eqn n 0) lst)
    (T (tail (cdr lst) (sub1 n)))))

% Routines for reading from and printing into strings.
(fluid
  '(
    string_for_read_from_string
    index_for_string
    string_input_channel
    string_output_channel
    print_dest_string
    print_indx
    flush_output))

% Set up the channels at load time.
(LoadTime
  (progn
    (setf SpecialWriteFunction* 'ReadOnlyChannel)
    (setf SpecialReadFunction* 'channel_read_from_string)
    (setf SpecialCloseFunction* 'DummyClose)
    (setf string_input_channel (open "string_reader" 'SPECIAL))

    (setf SpecialWriteFunction* 'channel_write_into_string)
    (setf SpecialReadFunction* 'WriteOnlyChannel)
    (setf string_output_channel (open "string_writer" 'SPECIAL))))

% READ from a string.  Argument is a fluid.
(de read_from_string (string_for_read_from_string)
  (prog (index_for_string  value)
    (setf index_for_string 0)    % index_for_string is also fluid.

    % Kludge to flush out input channel.
    (ChannelUnReadChar string_input_channel 0)
    % Read the value from the "magic" string reading channel.
    % Use ErrorSet to catch problems (such as trying to read an unbalanced
    % expression).  Rebind fluid !*BREAK to prevent a break loop if the
    % read fails.
    (let ((*BREAK NIL))
      (setf value
        (ErrorSet
          `(channelRead ,string_input_channel)
          T      % Allow error messages to be printed
          NIL))) % but, don't print backtrace stuff.

    (return
      (cond
        ((pairp value) (car value))
        % If there was an error in reading the string, just return NIL???
        % Or, pass the error on down?
        (T NIL)))))

% Ignore the channel argument, read next character from string in fluid
% "string_for_read_from_string", if any.  Return an end of file if none
% left.
(de channel_read_from_string (chn)
  (prog (val)
    (cond
      % If past end of string, return an EOF.
      ((GreaterP index_for_string (size string_for_read_from_string))
        (return (char EOF))))

    % Otherwise, return the appropriate character from the string.
    (setf val (indx string_for_read_from_string  index_for_string))
    (setf index_for_string (add1 index_for_string))

    (return val)))

% PrintF into the string "print_dest_string", starting at index
% "print_indx".  (Both of which are FLUIDS.)  Return the "printed into"
% string.  This code should probably be made more efficient (SysLispified?)
% someday.  Also, the number of legal arguments is sort of flakey.  Roughly
% modeled after the code for BldMsg.
(de PrintF_into_string
  (print_dest_string   print_indx  format
    arg1 arg2 arg3 arg4 arg5 arg6 arg7 arg8 arg9 arg10)

  (prog old_outchan
    % Switch to special channel for printing into strings.
    (setf old_outchan OUT*)
    (setf OUT* string_output_channel)

    % Kludge to clear the line position counter
    (setf flush_output T)
    (WriteChar (char EOL))

    (setf flush_output NIL)
    % Now use PrintF to the appropriate "magic" channel.
    (PrintF format arg1 arg2 arg3 arg4 arg5 arg6 arg7 arg8 arg9 arg10)

    % Select original channel
    (setf OUT* old_outchan)

    % Return the printed into string.
    (return print_dest_string)))

(de channel_write_into_string (chn chr)
% Ignore the channel argument, write character into fluid
% "print_dest_string", at location print_indx.
% We're careful to check bounds, since bad things could happen if we try to
% print an error message during this process!
  (cond
    % If "flush" flag is clear, and everything is within bounds. 
    ((and
       (null flush_output)
       (leq 0 print_indx)
       (leq print_indx (size print_dest_string)))
      % then print into the string
      (progn
        (setf (indx print_dest_string print_indx) chr)
        (setf print_indx (add1 print_indx))))))

% Dummy routine to close up channel I/O.
(de DummyClose (chn)
  NIL)