lispf4.orig

******HELP
Note.
in the code there are some nonstandard statements.


In the function ratom we use double precision variables to pick upp
the value of a number beeing read. This is beceause we dont want to loose
precision when reading big integer numbers.

But then we make integer numbers
and single precision real numbers by assignment. Here you can solve
this problem by either removing the double precision declaration
or use some conversion function on your computer (double to integer,
double to real, integer do double).




   Installing Lispf4
   =================

 Lispf4 is delivered as ONE file, EXPORT, containing source code in
 Fortran, Lisp, and assembler language (only for Dec10/20 and IBM).
 Each subfile in EXPORT starts with a line containing
   ******<filename>
 where <filename> is the name of the source code file.
 The subfiles are
   HELP     this text
   DOC      installation (and user) guide
*  FLOSOR   auxiliary routines for the interpreter
*  HEART    the heart of the interpreter
*  F4COM    COMMON block with areas used by the interpreter
   MOD      modifications for full prompting (see below)
   OPENF    modifications for symbolic file names (see below)
   DEC20    assembler routines for DEC20
   DEC10    assembler routines for DEC10
   VAXFTN   machine dependent routines in Fortran for VAX11
   VAXLSP   machine dependent Lisp functions for VAX11
   IBM      assembler routines for IBM
*  FLOSYS   data file for initialization of Lispf4 bootstrap
*  LIBRRY   library functions in Lisp for Lispf4 bootstrap
   DEBUGLOG log of run with debuglines in floexp enabled

The only files that are needed to get a "primitive" system
are the 5 files marked with "*". The other files can of course
be of help if you want to fix symbolic I/O and other things.



 Below follows an overview of the installation process. You should
 also read the installation guide (subfile DOC).

 Do the following to install Lispf4:

1. Split EXPORT into the various subfiles with, e.g., an editor.
   The second subfile contains the documentation of the system with
   installation guide.

2. Find the subroutine INIT1 in the subfile FLOSOR, where some machine 
   dependent constants are defined. Change them according to the
   documentation. Note that you probably need to change declarations
   of the COMMON block in the subfile F4COM. Some areas in F4COM should
   be declared INTEGER*2 in order to save space considerably
   (e.g. CAR, CDR, and stacks). In the file delivered there are INTEGER*2
   declarations on those places where such declarations should be done.
   However, you may not get enough Lisp cells with INTEGER*2; in such
  cases you should change all INTEGER*2 declarations into INTEGER, after-which
   you may increase the CAR/CDR areas (don't forget NFREET in INIT1) from
   the current 28000 ('optimal' for INTEGER*2 CAR/CDR) into, e.g., 38000.

   All areas are declared in the COMMON block F4COM.
   The Fortran program contains statements
      INCLUDE 'F4COM.FOR'
   on those places where F4COM should be inserted.

   Caution! Don't forget to redimension IMESS, and to change FORMATs in
   RDA4 and WRA4.
   Note also that the subroutines SETCHT and GETCHT in FLOSOR make use of
   the fact that A1 format characters are stored left justified.
   On, e.g., VAX11 SETCHT and GETCHT must be redefined using the
   Fortran function MOD. (The constant CHDIV is then unused).

3. When all constants are defined you may compile and link Lispf4.
   LISPF4 uses the Fortran source code in the files FLOSOR,  HEART,
   and DUMMY.
   You may also need to program two machine dependent routines in
   assembler or Fortran (GETCH and PUTCH, see documentation).
   Be absolutely sure that GETCHT, SETCHT, GETCH, and PUTCH work
   before testing Lispf4!

4. Now you can start LISPF4. It will read some messages from logical unit
   LUNSYS (default 23). Connect LUNSYS to the subfile FLOSYS.

5. If the system starts properly you get an underline (_) as prompter.
   If the system does not start properly it's time to try to find out what was
   wrong. Most problems with lispf4 are with text and I/O. If you get problems
   you  can enable the debug lines in floexp (marked CDEBUG) and run
   lispf4. The debug lines print various parts of the buffers and pname
   on lunuts (the terminal). A log of what this output should look like is
   supplied in the file DEBUGLOG. You have to modify the A5 format in the
   debug lines to whatever A format is a  integer on your machine.
   The DEBUGLOG also shows how to load the librray file.
   Note ! on DEC20 fortran runtime will ask for a filename if you try
   to read or write on a unit that is not opened. In other systems you
   would have to open the LIBBRY.LSP file on unit 55 to get the same result
   as in the logfile. (same thing with flosys.lsp and unit 23)

6. At this point you should be able to talk to Lisp. Call the function
      (IOTAB 1 x)
   where x is logical unit number for the subfile LIBRRY.
   (this file contains all library functions and will load them all,
   if you dont want all packages you have do edit the file yourself)

7. When the file is loaded do
      (ROLLOUT 'LF3)
   The system will ask for logical unit number. Answer with logical unit
   number connected to a Fortran file for binary (unformatted) writing/reading.

8. If everything worked, try to do
     (ROLLIN 'LF3)
   and to answer with the same logical unit number as by the ROLLOUT.

9. Now LISPF4 should work!

10. Most operating systems allow references to physical file names from
    Fortran. If your OS disallows this then GOTO 12.
    Modify the function OPENF in FLOSOR, which, given a pointer to a Lisp
    string containing a file name, opens the file and returns a new
    logical unit number. The current code is made for DEC10/20.
    You must also modify the Lisp function SOPENF in the subfile LIBRRY
    which takes a Lisp file name and constructs a physical file name
    for your OS. E.G. for DEC20 it transforms the Lisp file name FOO
    into DSK:FOO.LSP before calling OPENF (Lisp function OPEN0).

11. Load OPENF before FLOSOR.

12. Compile the subfile INIT2 and put it first in the load list.
    INIT2 intercepts some initiation code in LISPF4 by directly reading
    the LISPF4 rollout from a logical unit number defined in INIT2.

13. Now we have the load order
        INIT2,(OPENF,)FLOSOR,HEART
    Load, link, and save the load module.

14. Run the load module. the system should read the LISPF4 rollout from
    unit 7 (or whatever you define in INIT2).

15. If you have defined your own OPENF then set
       (SETQ SYMBIO T)
    and roll it out on the physical file LF4 with
       (ROLLOUT 'LF4)

16. Lispf4 prints a prompt text when reading from the terminal.
    (The SUBR PROMPTTEXT may change this prompt text)
    In the delivered version the prompt text is printed on a separate
    line, but you probably prefer to print it without line feed.
    Since it is machine dependent to print Fortran strings without
    ending line feeds, you then need to redefine two I/O routines.
    The subfile MOD contains the modified code for DEC20; it is
    probably rather similar on your computer.
    MOD should be loaded before FLOSOR.

17. Most operating systems allow you to make a subroutine which is called
    when the user types a special interrupt character on the terminal
    (CTRL-H on DEC20, CTRL-C on VAX11, BREAK on IBM etc)
    In Lispf4 you may use this for interrupting the interpretation.
    You must then make an assebler routine, BRSET, which sets up an
    interrupt so that the subroutine BRSERV (without arguments) is called
    whenever the user types the interrupt character.

    The assembly code for DEC20 and IBM contains code for interrupt
    handling. Note that there are some minor changes in the main
    Fortran program for IBM. (As indicated by comments in the source
    code). The interrupt handler for IBM is written for the time sharing
    system GUTS, which should simulate correctly (hopefully) TSO.

18. On some operating systems there may be a problem that the hash
    function of Lispf4 makes use of the fact that A1 format characters
    are left justified in the word. On such systems (e.g. VAX11) you 
    should redefine the function IHADR in the subfile FLOSOR.

19. On some computers (e.g. DEC20) CAR and CDR is represented more
    efficiently by using half word pointers, but the Fortran compiler
    cannot handle small integers. In such cases one may implement CAR and
    CDR as (assembly) functions. 
    For RPLACA and RPLACD two more subroutines SETCAR(X,Y) and SETCDR(X,Y)
    need to be defined and all CAR(X)=xxx and CDR(X)=xxx must be replaced
    with calls to SETCAR and SETCDR. To simplify this all such places in
    the interpreter have the fortran line
     C*SETC*R       statement
    where 'statement' is the call to SETCAR/SETCDR replacing the previous
    Fortran line. The assembly code for DEC20 contains code for handling
    of half word integers.
      CAR,CDR,SETCAR, and SETCDR as subprograms may also be used for other
    purposes, e.g. software paging.



   In the text above we say that something should be loaded "before"
   something else. This is only a way of getting a specified module
   loaded if there are more than one module with that name. I.e in the code
   there is a dummy defined OPENF function if you have written your own
   openf you can on DEC20 

         load my-openf,main-code

   and your openf will be loaded and not the dummy one in the main code.
   If this is not possible you have to remove the OPENF dummy function in 
   the main code.
******DOC         (LISPF4 DOCUMENTATION)
INTRODUCTION
 
LISP F4 is a LISP interpreter written in FORTRAN IV.  The interpreter
is (almost) a subset of INTERLISP.  LISP F4 originates from LISP 1.5
through LISP F1 to LISP F3.  LISP F4 is about 3 - 10 times more
efficient then LISP F1 and have features like floating point numbers
and arrays.  LISP F4 is easy to implement.
 
This document contains two parts, a users guide and a implementation
guide.  The users guide presupposes basic knowledge of the LISP commands
and functions (See Haraldsson LISP-details, referred to as Ha 75).
 
       *********      USER'S GUIDE     ************
 
PRIMARY DATATYPES
 
Small integers         Range -n,n where n is implementation
                       dependent.
                       If x is the maximum positive integer
                       in a full word, n is x-size of CAR,CDR
 
 
Floating point         Range depending on the size of a full word
numbers                Characterized by BYTES, IRESOL, IPOWER, FUZZ.
 
Lists                  Given as (A B (C D)) etc.
 
Strings                Given as "THIS IS A STRING"
 
Alfanum atom.          Max. no of characters = size of I/O-buff/2
                       (default = 80).
 
Arrays                 Containing pointers,
                                  integers and
                                  floating point numbers.
 
INTERNAL REPRESENTATIONS
 
A more complete description of the internal representations is
needed for a complete knowledge and usage of LISP F4 from the user's
point of view.
 
a)          THE ADDRESS SPACE.
 
The address space is shown by the following figure:
 
1                                                                 MAX
I---------------------I----------I---------------I-----------------I
NIL   alphanum atoms     lists      pointers to      pointers to
      and strings                   real numbers     small integers
 
MAX = the largest positive integer in a halfword (or full word) in
your computer.
 
b)          ALPHANUMERICAL ATOMS AND STRINGS.
 
 
               CAR             CDR
        I----------------I----------------I
        I                I             --------> property list
        I-------I--------I----------------I
                V
         global value
 
The global value of an atom is stored in CAR(atom).  (EVAL checks for
 
a bound value BEFORE a global value - as in INTERLISP but in
contradiction to LISP 1.5).  A global value may be set either by
SET/SETQ at the top level, or directly by RPLACA.  If a global value
has not been assigned, car(atom) points to the atom NOBIND.
 
STRINGS are represented exactly as atoms except for
- car(string) points to the atom STRING
- Two different strings may have the same printname.
- Strings always have themselves as the value.
 
SUBSTRINGS are like strings, but instead of having a print name
- car(substring) = SUBSTR
- cdr(substring) = (sourcestring start .length)
 
PRINTNAMES are accessed through the pointer representing the atom
and hidden from the user in a special area.
 
FUNCTION DEFINITIONS.
In INTERLISP each atom-record also has a "function field" called
function cell (Ha 75 page 4).  In LISP F4 user defined functions
are stored as LAMBDA or NLAMBDA expressions under the property
FNCELL. SUBR's and FSUBR's are recognized by their pointer-value
but in order to simulate the facility of making use of "free
function indicators", GETD is defined to return (SUBR . FOO) if
FOO is a FORTRAN coded SUBR, and (FSUBR . FOO) if it is a FSUBR.
 
The forms (SUBR . FOO) and (FSUBR . FOO) are simulated function
indicators and legal function arguments to apply.
 
Ex.:
        (DE KAR(X) ((SUBR . CAR) X>
 
This definition of KAR causes KAR to behave exactly as CAR
independently of whether CAR has been redefined to something else.
 
c)          FLOATING POINT NUMBERS AND ARRAYS
 
FLOATING POINT NUMBERS are stored in consecutive floating point words in
upper PNAME.
 
Atoms obeying the following syntax are treated as numbers.  If
floating point numbers:
 
     number::= sm ! smEsn
     s     ::= + ! - ! empty
     n     ::= d ! dn
     d     ::= 0 ! 1 ! 2 ! 3 ! 4 ! 5 ! 6 ! 7 ! 8 ! 9
     m     ::= n ! n. ! n.n ! .n
 
The "E" has the same meaning as in Fortran.
 
Floating point numbers are printed as compactly as possible,
either with or without the "E".
 
ARRAYS contain pointers, integers or floating point numbers.
CAR(pointer value) = LISPF4-ARRAY
CDR(pointer value) = NIL
By this means it is possible to call a Fortran subroutine with an
actual parameter consisting of an address to an array part if the
corresponding formal parameter is a properly typed array.
 
Arrays cannot be read-in.  They are printed as
 
     #xxx         # = left square bracket
 
where xxx is the array pointer value.
 
d)          THE SYMBOL TABLE CAN BE LOOKED UPON
 
The function
        (OBLIST x)
creates a new list of atoms, with the last atom created as the first
member of the list, and the atomic argument x as the last one.  As
as T is the last one defined by a "clean" system, (OBLIST T) gives you
all but SUBR's and FSUBR's.
 
e)          VARIABLE BINDINGS IN PARAMETER STACK
 
Variable bindings are stored in a parameter stack (as in Interlisp)
and is implicitly given to EVAL, APPLY and EVLIS.
 
 Functions that use the stack.

If you want to evaluate something and skip part of the stack
you use the function EVSTK

           (EVSTK form stkpos)

This function works like eval but begins searching the stack at
stkpos.

If you are used to a function  EVALA (lisp 1.5) this is what you
should use (EVALA works but will put the alist on the stack and
that takes time)

To get a stkpos you use the function BINDENV

           (BINDENV var)

           returns stackaddress to the block before the block
           where var is bound.
           The address is returned as a smallnum 
           pointing to the topmarker of the block.
           If you try to supply anything that don't point
           to a topmarker to EVSTK or APPLYSTK you will
           get an error. This means you can only
           get lisp to start searching at a block boundary.

_(DE TEST (BAR)(PROG () (PRINT BAR)(PRINT (EVSTK 'BAR (BINDENV BAR>
TEST
 
_(SETQ BAR 88)
88
 
_(TEST 77)
77
88
NIL
 
            The function TEST is defined to print its argument
            and print the value of it's argument outside it's
            own block.

The function applystk  will do the same as applya in the same way.
       
             (APPLYSTK func list stkpos)

To safe definitions of RPTQ and SETQQ

(RPTQ
  (NLAMBDA (N X)
        (APPLYSTK 'RPT (LIST (EVSTK N (BINDENV N)) X) (BINDENV N))))

(SETQQ
  <NLAMBDA L (APPLYSTK 'SET L (BINDENV L>)


To look at the stack there is the function  BTV*

 
_(PP BAR)
(BAR
  (LAMBDA (U) (FOO (ADD1 U))))
  
(BAR)
 
_(PP FOO)
(FOO
  (LAMBDA (X) (FUM (LIST X 77))))
  
(FOO)
 
_(PP FUM)
(FUM
  (LAMBDA (L) (BTV*) (PRINT (REVERSE L))))
  
(FUM)
 
_(BAR 567)
Environment    Tops  
     11         13
#13  <0  11>
#12  *FORM (BTV*)
#11  <-8  8>
#10  L (568 77)
#9   *FORM (FUM (LIST X 77))
#8   <-5  5>
#7   X 568
#6   *FORM (FOO (ADD1 U))
#5   <0  2>
#4   U 567
#3   *FORM (BAR 567)
#2   <0  0>
#1   *FORM (LISPX)
***  Bottom  ***    
 
(77 568)
(77 568)


The function ALIST will build a list of dotted pairs
with the variable and it's value from the stack.
ALIST with no argument will not include the *FORM variables
but (ALIST T) will.


_(DE A(X Y)(B 6 Y))
A
 
_(PP A)
(A
  (LAMBDA (X Y) (B 6 Y)))
  
(A)
 
_(DE B(Z W)(SETQ R1 (ALIST))(SETQ R2(ALIST T>
B
 
_(PP B)
(B
  (LAMBDA (Z W) (SETQ R1 (ALIST)) (SETQ R2 (ALIST T))))
  
(B)
 
_(A 567 88)
((W . 88)
  (Z . 6)
  (*FORM B 6 Y)
  (Y . 88)
  (X . 567)
  (*FORM A 567 88))
 
_R1
((W . 88)
  (Z . 6)
  (Y . 88)
  (X . 567))
 
_R2
((W . 88)
  (Z . 6)
  (*FORM B 6 Y)
  (Y . 88)
  (X . 567)
  (*FORM A 567 88))
 
Two small functions are defined. The last of them will
set R1 to (ALIST) and R2 to (ALIST T)

f)          LISTS are represented as two pointer records with
            CAR and CDR fields.
 
g)          NUMBERS ARE IMPLEMENTED AS HIGH VALUED POINTERS.
 
The value of a small integer is the value of the pointer subtracted
by a proper offset.  The value of a real number is stored in a full
word hidden from the user (but found through its pointer value).
 
ATOMS OF PREDESIGNED MEANING
 
Here is a list of those atoms which may be of interest for the LISP F4
user.
 
NIL,T           These atoms can not be destroyed by any functions
                such as RPLACA etc.
NOBIND          is stored in car of undefined atoms.
LISPF4-STRING   is stored in car of strings.
LISPF4-SUBSTR   is stored in car of substrings.
LISPF4-ARRAY    is stored in car of arrays.
ADVISEDFNS      List of advised functions.
BROKENFNS       List of broken functions.
CURFNS          List of those functions which have been defined
                before the first time (CURFILE file) was preformed.
CURFILE         Name of the current file (used by the MAKEFILE
                package).
FILELST         List of files loaded so far.  Updated by the function
                CURFILE.
*PRINTLEVEL     The printlevel used by TRACE.
 
I/O HANDLING
 
Though LISP F4 was designed to be as true a subset of INTERLISP as
possible, there do exist some minor differences.  Most of then have
to do with I/O.
 
a)          INPUT CHARACTERS OF SPECIAL MEANING.
 
.           for dotted pairs.  Must be separated by blanks!
            A '.' which can not be interpreted as 'a dotted pair'
            is read as an atom.
%           escape character
'           QUOTE character
" "         string character
<>          super brackets
 
All those characters works the same as in INTERLISP.
 
~           'rescue character'.  When this character is seen by
            the read routine, LISP F4 will enter BREAK.  (Useful
            for infinite read loops for example).
 
b)          CHANGING THE MEANING OF SPECIAL CHARACTERS.
 
The "meaning" of all characters are stored in a table which is
accessible by the function
 
            (CHTAB x)     Read the type of x
            (CHTAB x n)   Change the type of x.
                          Returns old type.
 
CHTAB uses the first character of the atom x.
The following character table is standard.
 
        Type          Means
        1             space
        2             (
        3             )
        4             <
        5             >
        6             "
        7             '
        8             user break
        9             .
        10            alphanumerical
        11            +
        12            -
        13-22         0-9
        23            %
        24            rescue character
        25            E  exponent
        26            # = square bracket
 
Ex.:  If you want to have $ as a super bracket, and > as an ordinary
letter do:
 
        (SETQ TYPE (CHTAB '%> (CHTAB 'A>
        (CHTAB '$ TYPE)
and if you want to have * as a break character do
        (CHTAB '* 8)
 
after which A*B will be read as the three atoms A * B separately.
 
c)          CHANGING LOGICAL UNITS ETC.
 
All I/O functions refer to a table with the following meaning:
 
        No            Means
        1             FORTRAN logical input no
        2             current read position
        3             left margin - input
        4             right margin - input
        5             FORTRAN logical output no
        6             current print position
        7             left margin - output
        8             right margin - output
        9             the print length
        10            the print depth
 
The table us accessible by the function
 
        (IOTAB i)     read position i in the table
        (IOTAB i val) put val in position i.  Returns
                      old value.
 
If val is T and i is 1 or 5, the default value (= standard Input/Output)
is put in position i.
 
A number of basic functions coded in LISP such as READPOS, INUNIT etc.
are defined by using IOTAB, so in practice you rarely use IOTAB
yourself.
 
d)          CHANGING STANDARD BEHAVIOR OF LISP F4.
 
The function
        (SYSFLAG i)      Read flag i.
        (SYSFLAG i x)    Change flag i to x (=T or NIL).
                         Returns old value.
is used to read/write flags with the following meaning:
 
        Flag no T (which is default) means:
        1           GBC message
        2           output is pretty printed
        3           (QUOTE s) printed as 's
        4           convert atoms to capital letters (machine dep.)
        5           Add % and " when so needed for a
                    correct read back.
        6           unused
        7           Print sublists on separate lines, unless
                    it is the first (or sometimes second) sub-
                    expression.
                    NIL means: during pretty print, do not begin
                    a new line if the current expression will
                    fit on line.
 
e)          BASIC I/O FUNCTIONS.
 
The following functions work as in INTERLISP except that they do not
have a file argument.
 
(READ)        (RATOM)        (READC)
(PRINT x)     (PRIN1 x)      (PRIN2 x)     (TERPRI)
(EJECT)       (SPACES n)
 
 
In addition the following functions are defined using IOTAB.  If
n is NIL they return the current value, otherwise a new value n is set
and the old value is returned.
 
(INUNIT n)       logical input no
(OUTUNIT n)      logical output no
(PRINTLEVEL n)   the max depth of printing.  (Lists below
                 this level will be printed as ...)
(PRINTLENGTH n)  the max length of printing.  (Elements
                 beyond this length will be indicated as ---)
 
As a matter of fact, PRINT, PRIN1 and PRIN2 are also defined in
LISP using the one and only printing function PRIN0 which is defined
as:
 
      (PRIN0 x a b)
 
      x      value to be printed (No TERPRI before or after!)
      a      =NIL Do not print % or "
             =T   Print % or " when so necessary to read
                  atoms back
             =T   pretty print with flag no 7 = NIL
             =n   (a number)      - " -       = T
 
During pretty-print, lists headed by an atom carrying the function
definition (FSUBR . QUOTE) will be treated as comments:  They will
be printed starting from 20 pos. to the left of the right margin.
Ex.:  By doing (PUTD '* (GETD 'QUOTE)) * behaves as QUOTE and
expressions like (* comment comment ...) will be printed as comments.
In addition two functions are defined:
 
      (PRINTL s1 s2 ..)
 
preforms PRIN1 on s1 s2 etc.
 
      (PRINTL-SP s1 s2 ..)
 
works as PRINTL but separates s1 s2 etc. by spaces.
 
The function

      (PROMPTTEXT string)

allows you to specify a prompt text to be printed when reading from the
terminal.

A new function REWIND is defined:
 
      (REWIND n)     Rewinds the logical unit n.
                     Rewind should be logically the same as closing the file.
 

f)          SAVE/RESTORE OF THE CORE IMAGE.
 
The functions
      (ROLLOUT lu)
      (ROLLIN lu)
 
saves/restores a compact core image of the status of LISP F4.  This
read them back at a later stage.  (an other way of saving is to use
MAKEFILE)
 
It is possible to perform ROLLIN also if the size of LISP F4 has been
changed since the last ROLLOUT.  If though the new version is too
small to hold the saved core image ROLLIN returns NIL (= failure to
rollin)
 
g)          THE MAKEFILE PACKAGE.
 
This package is coded in LISP and follows the conventions for
INTERLISP makefile.  The only commands in FILEVARS which are
implemented are:
 
       * (P ...) (PROP ...) (E ...) (IFPROP ...)
 
The MAKEFILE package is designed to work in a similar way both if your
Fortran dialect allows for symbolic file names and for only logical unit
numbers.

If you use symbolic file names, MAKEFILE and LOAD will behave as in Interlisp.

If you need to use logical unit numbers, MAKEFILE and LOAD will prompt you
for the logical unit number of the file corresponding to the symbolic name
given to MAKEFILE/LOAD. You may also provide this association with the function
 
       (OPEN file io no)
       file   your symbolic name
       io     I or INPUT for input files
              O or OUTPUT for output files
              other for input/output files
       no     FORTRAN logical unit
 
and if you have no further use of the file you may remove its logical
unit number by
 
       (CLOSE file)


For systems allowing references to physical file names MAKEFILE, LOAD,
ROLLIN, and ROLLOUT use the SUBR

      (OPEN0 file input mode)

which opens a sequential file named 'file'. If the flag 'input' is T the
file is opened for input, otherwise for output. 'mode' is T if the file
is a ROLLIN/ROLLOUT file, and NIL otherwise. OPEN0 opens the
file and returns a logical unit number which can be used by INUNIT, and
OUTUNIT, ROLLIN, or ROLLOUT.

The function

       (CURFILE file)
 
declares that new function definitions shall 
belong to this file and will be added to the list fileFNS.
The global variable CURFILE contains the name of the current file.
 
 Ex.:  Define some functions and save them as your file MYFILE on the
logical unit 25.
 
        (OPEN 'MYFILE 'O 25)       (this line not needed when your system
                                    uses symbolic file names, or if you let
                                    MAKEFILE prompt you for logical unit
                                    number of MYFILE)
        (CURFILE MYFILE)
        (DE ....>
        (DE ....>
        etc.
        (MAKEFILE 'MYFILE T)
 
A pretty printed version of all functions is now written on unit 25
(argument no 2 is used as PRIN0's argument no 3 when it performs the
printout).
 
ERROR HANDLING AND BREAK.
 
Mostly all errors detected by LISP F4 call the function SYSERROR
which is a SUBR and which calls RESET after printing a message.
SYSERROR is then redefined in one of the standard LISP packages as
a LAMBDA function which calls BREAK1 after the message.

BREAK1 is the ordinary "break-function" and may therefore also have been
called by a user setup break, and inside BREAK1 the following
commands exist:
 
        !        return to previous break if any. Otherwise reset.
        GO       print "broken form" and continue.
        OK       continue
        RETURN x return the value of x.
        EVAL     eval broken form and break afterwards.
                 The value of the form is stored in the atom !VALUE
        !EVAL    as EVAL etc, but the function
        !GO         is first unbroken
        !OK         then rebroken
        UB       unbreaks the function.
        BR       breaks the function.
        BT       backtrace of function calls 
        BTV      backtrace of function calls and variable bindings
        (BTV*)   (a function call!). Total backtrace of everything on
                 the parameter stack.
        ?=       prints the arguments of the broken function
 
        any other input is evaluated and value is printed.
 
In addition to BREAK1, the functions BREAK0 BREAK UNBREAK REBREAK and
TRACE are defined and work as in INTERLISP.
 
There also exists a function BREAK11, which is a LAMBDA version of
BREAK1 (which in turn is a NLAMBDA) and a function UNTRACE.
 
Each error is associated with a number.  The function
 
        (ERRORN)
 
returns the number for the last error occurred, and
 
        (ERRORMESS n)
 
prints out a corresponding message.
 
Note that you may modify SYSERROR in order to introduce your own handling
of certain types of errors. For example, it is trivial to introduce run 
time expanded macros by using SYSERROR. You then only have to modify SYSERROR
so that the macro is expanded and evaluated if you get 'undefined function'
((ERRORN)=2) and if the undefined function has a macro definition.

On most computers it is possible to associate an interrupt with some
special character so that an interrupt occurs whenever the user types that 
character. In the implementation guide it is described how to implement
keyboard interrupts within Lispf4. If your implementation has keyboard
interrupt you will enter a BREAK whenever you type the interrupt character.
The interrupt feature is very useful for breaking indefinite looping.
It may also be used for interrupting printings of large S-expressions.

The interrupt characters  are normally
    DEC20:        CTRL-H
    VAX11:        CTRL-C
    IBM/370:      BREAK
Check with your Lispf4 implementor for the interrupt character on your
Lispf4 implementation!

EDIT
 
Two edit functions are implemented:
 
        (EDITF fn . edcom)    edit a function.  Value = NIL.
        (EDITS s edcom)       edit any s-expr.  Value = s
                              edcom = list of edit commands
                              (or NIL).
 
The following commands are implemented.
 
        P                Print to level 2
        PP               PrettyPrint to level 2
        ?                Print to level 100
        ??               PrettyPrint to level 100
 
Note: In INTERLISP the print commands are not exactly as ours.
 
        OK               Leaves the editor
        UP               Sets the c(urrent)expr, so that car of
                         new cexpr is equal to the old cexpr.
        F expr           searches the first occurrence of expr
                         in the cexpr regardless of level
        NX               next expression
        !                sets cexpr to top level expression
        S x              set x to cepr.  Useful in combination
                         with US.
        n                An integer, if positive set cexpr to the
                         n:th element of cexpr, if negative to the
                         n:th element from the end, and if n=0
                         cexpr := superexpression which contains cexpr.
        (n)              n >= 1 deletes the n:th expression of cexpr
        (n e1 ...)       n >= 1 replaces the n:th expression by e1 ...
        (-n e1 ...)      n >= 1 inserts e1 ... before the n:th element.
        (N e1 ...)       adds e1 ... to the end of cexpr
        (R x y)          All occurrences off x are replaced by y.
        (BI n m)         Both In.  Aleft parenthesis is inserted before
                         the n:th element and a right parenthesis is
                         inserted after the m:th element.
        (BO n)           Both Out.  Removes both parenthesis from the
                         n:th element.
        (LI n)           Left In.  Inserts a left parenthesis before the
                         n:th element and a corresponding right at the
                         end
        (LO n)           Left Out.  Removes the left parenthesis from
                         the n:th element.  All elements after the
                         n:th element are deleted.
        (RI n m)         Right In.  Inserts a right parenthesis after
                         rest of the n:th element is brought up to the
                         level of the current expression.
        (RO n)           Right Out.  Removes the right parenthesis from
                         the n:th element, moving it to the end of the
                         current expression.  All elements following
                         the n:th element are moved inside the n:th
                         element.
        (: e1 ...)       Replaces current expression by e1 ...
        (MBD e1 ...)     Ex.:  We have (PRINT X) and we want
                               (COND ((NULL L) (PRINT X) NIL)
                                     (T (PRINT X) (GO LOP)))
                               we do
                               (MBD (COND ((NULL L) * NIL)
                                          (T * (GO LOP))))
        (XTR e1 ...)     Ex.:  We have (COND ((NULL L) NIL)
                                             (T (PRINT L))
                               and we want (PRINT L)
                               we do
                               (XTR 3 2), (XTR (PRINT L)) or
                               (XTR PRINT)
        (MARK x)         Save the current chain in x.
S and US can be used in different edit sessions.
 
Ex.:  Move the PROG expression of FOO to be the PROG expression of
another function FII.
 
        (EDITF FOO)
        F PROG S DEF OK
        (EDITF FII)
        (US DEF (3 DEF)) OK
 
The 3:rd element (the prog expression of FII) is replaced by the one
stored in DEF.
 
MISCELLANEOUS
 
A new function GO* is defined as a FSUBR.
 
        (GO* LAB)
 
searches through all current PROG's for a label LAB.  If it is found
a jump is performed.  If it is not, NIL is returned and no other action
takes place.
 
GO* is a way of implementing ERRORSET, ERRORBANG, TRYTOEVALUATE, FAIL,
etc.
 
Ex.:
ERRORSET is defined as:
 (DE ERRORSET (ERRORFORM ERRFLG)
             (PROG NIL
                   (RETURN (LIST (EVAL ERRORFORM)))
               ERRORSET>
 
and SYSERROR is defined as:
 
(DE SYSERROR (ERRORTYPE FN ARG FORM)
             - print message if ERRORFLG = T -
             (GO* ERRORSET)
             (BREAK11 FORM T NIL>
 
When SYSERROR is called it tries to jump to the laber ERRORSET.  If it
succeeds (error occurred under errorset) a "big jump" to ERRORSET is
performed and the function ERRORSET returns NIL.  Otherwise BREAK11 is
called.
 
String functions:
 
In addition to those explained in Ha 75 (page 108) three new string
functions are defined:
 
             (STRALLOC n c)
 
The first character of the literal atom (or /sub/string) c is fetched,
and a new string of length n is allocated, and filled with the character
from c.
 
Other functions not reported in Ha 75 are:
 
             (ABS n)
             (ADDLIST a l)    if memb(a,l) then l else cons(a,l)
             (SORT l)         Destructive sorting function
             (EVLIS l)        mapcar(l,'EVAL)
             (GCGAG flg)      Print message when GBC (if flg = T)
             (NTH l n)        Performs CDR n-1 times on l
             (RPT n s)        evaluate s n times
             (RPTQ n s)       as RPT but s is not evaluated at calling
                              time.
             (SIGN n)         0 or 1 or -1 depending on the sign of n
             (CLOCK)          time in milliseconds.
             (TIME)           time of the day
             (DATE)           current date
                              Note that the implementation of CLOCK, TIME,
                              and DATE are machine dependent. They are
                              implemented by the subroutines MSLFT, TIME,
                              and MDATE.
                              
             (RECLAIM n)      n=0 Normal GBC
                                1 Compacting GBC
                                2 Big number GBC
                                3 Big number/Atom GBC
             (XCALL fn l)     A way of calling FORTRAN routines.
                              Returns NIL in the virgin system.

 
Array and floating point functions
 
             (ARRAY s si sf) = a
 
Creates an array with space for s elements.  Out of these s elements,
si are to be integers and sf are to be floating.  The elements are
initially set to NIL, 0 ,and 0.0, respectively.
 
             (ARRAYSIZE a) = (s si sf)
 
gives the sizes of the array a.  S, si and sf have the same meaning
as above.
 
             (ELT a j) = x
             (ELTI a j) = i
             (ELTR a j) = f
 
picks the element j of the pointer, interger or floating part of a.
Within each part, the elements are indexed from 1 and upwards.
 
             (SET a j x) = x
             (SETI a j i) = i
             (SETR a j f) = f
 
 
             (IQUOREM j k) = (quotient . remainder)
 
This function performs an integer division of j by k.
 
             (ARRAYP a) = a or NIL
 
ARRAYP returns a if a is an array, otherwise NIL.
 
             (FIXP i) = i or NIL
 
FIXP returns i if i is a small integer, otherwise NIL.
 
             (FLOATP f) =f or NIL
 
FLOATP returns f if f is a floating point number, otherwise NIL.
 
There is no special floating point arithmetics.  Instead, as long as
all operands in a computation are integers, integer arithmetics is used.
If any operand is floating, floating point arithmetics is performed.
 
          **** IMPLEMENTATION GUIDE ****
 
HOW TO IMPLEMENT LISP F4 ON YOUR COMPUTER.
 
The LISP F4 system consists mainly of three parts:
A.  The interpreter (master version) written in FORTRAN IV
B.  'SYS-ATOMS' A file which will be read by LISP F4 at initiation.
    (this file is named FLOSYS.LSP)
C.  Additional functions, written in LISP.
 
For easy and secure implementation do as follows:
 
1. (this section is removed)
 
2.
If you want to generate your own version or change in one of the pre-
designed versions, here are the variables at hand.
 
NAME       REMARK                               CORR. ARRAY IN COMMON
 
JBYTES     Bytes in a Lisp pointer
IBYTES     Bytes in an integer
BYTES      Bytes in a real number
           (BYTES and IBYTES must be multiple of JBYTES)
NATOM=n    No of atoms                          PNP(n+1)
NFREET=f   f > 2*n.  No of atoms + cons cells   CAR(f), CDR(f)
NSTACK=s   s > 500                              STACK(s)
NHTAB=h    h == 1.5*n                           HTAB(h)
                  == means "about"
NPNAME=p   p == 2*n                             PNAME(p+2)
HILL=hill  size of parameter stack              jack(hill),jill(hill)
           hill == s

IRESOL     The precision of a floating point number (in decimal digits).
IPOWER     max(abs(p)), if floating point numbers are represented as
           m*10**p, abs(m)<10
FUZZ       will compensate for truncation errors in certain cases.
           Should be set to 5*10**(-IRESOL)
NBYTES=nb  nb = 2**x, where x = no of bits in a
           byte (normally x = 6 for BCD, 7 for
           ASCII and 8 for EBCDIC).
           (Can be 8 for ascii too)
MAXBIG     The largest positive integer that fits
           in a full word.
MAXINT     The largest positive integer that fits
           in the word size used for CAR and CDR.
           (If you don't use half word integers,
              MAXINT = MAXBIG).
CHDIV=d    Used for calculating an index from a
           character.  If CH is an INTEGER,
           holding a character left justified the
           value of i=ABS(CH/d)+1 must be in the
           range (1,nb).  CHDIV is only used in
           routines GETCHT and SETCHT.  Make sure
           that they work!  If they do not, LISP F4
           will fail while reading the SYS-atoms
           and consequently never reach the LISP
           top-loop.
im         = MAXMESS*NBMESS/IBYTES              IMESS(im)
           Don't forget to redimension IMESS!

  The remaining system variables need only be changed in certain cases.

MAXMESS    Number of messages
NBMESS     Max number of characters in a message
           Change it only when you add more
           (and longer) messages to the system.
LUNIN=li   Logical input.
LUNUT=lu   Logical output.
LUNSYS=ls  Logical unit for the SYS-atoms.
MAXLUN     The largest logical unit number
           allowed
IOBUFF     Size of ABUFF, BUFF,RDBUFF and PRBUFF
           Normally = 150.
NCHTYP=c   No of different "character types"
           such as ( ) < > etc.
NAREA      Length of common /B/ from ARG to
           DREG(7).
 
 
3.
Depending on how many bytes an INTEGER can hold you may have to change
the FORMAT(...,A4) in RDA4 and WRA4 to FORMAT(...,A5) (or whatever)
 
4.
If your compiler requires it, insert a PROGRAM statement at the
beginning of the FORTRAN code.
 
5.
Observe, that the COMMON block is separated from the rest of the
FORTRAN code and replaced by:
 
     INCLUDE 'F4COM.FOR'
 
instead.  This makes it easy to change the common block.
 
6.  Non-standard FORTRAN routines
The routines GETCH and PUTCH are normally coded in assembler.
They used for moving bytes (characters) to/from an array.
They can also be coded in Fortran if your Fortran dialect allows for
byte manipulation. The subfile VAXFNT contains this Fortran code for VAX11
Fortran.

  Calling format:

      CALL PUTCH(VEC,CH,I) Move to place I in VEC from the character CH.
      CALL GETCH(VEC,CH,I) Move from place I in VEC to the character CH.
 
The character in CH is left justified (with space padding).  Characters
in VEC are numbered 1,2,.... (1 = the leftmost one). 
Note that some computers (e.g. VAX11) store characters right justified.  

The following three operating system dependent subprograms are
initially dummy defined. If you want them to work correctly you have
to define them according to your operating system.

The subroutine MSLFT(I) returns the number of milliseconds left in
the job. This value can be used to test how much time is left in the job
when you are running in batch. Nowdays lisp is usually run interactively
and the function is somewhat obsolete. On the DEC20 implementation
mslft returns number of milliseconds cpu time the job has consumed and
is used mainly for timing purposes.

The subroutine MDATE(ISTR) sets ISTR to the current date as a 
10 character string. If your computer returns date in an other format
that is not 10 characters (maybe 8 or 12) you will also have to change
in the HEART routine, the change is easy you have to tell the lengt in
2 places that are marked in the code. Search in the code for mdate and
change the two 10's to whatever lengt you use.

The subroutine MTIME(ISTR) sets ISTR to the current time of day.
If your time format is not 5 characters you change in the code as above.


The subroutine BRSET without arguments is used for setting up terminal
interrupts. BRSET should set up the interrupt so that the subroutine
BRSERV without arguments is called whenever the user types a predefined
break character (e.g. CTRL-H on DEC20, CTRL-C on VAX11, BREAK on IBM).

It is very machine dependent how you can trap interrupts. If the specification
above is difficult to implement you can do it in some other way.
The way it works is that whenever the user types a break character the logical
variable IBREAK in the common /A/ should be set to .TRUE.

7.
It is now time to compile and run the system.  Assign your
input (LISP-CODE) to logical unit li (normally teletype), and your
output to lu (normally teletype).  The file SYS-atoms should be
assigned to logical unit ls.  If all is OK so far, the system starts
(after reading the SYS-atoms) with a message
   LISP F4, LATEST UPDATE =
   .....
 
That is, when lispf4 starts it will read the system atoms from
the unit ls (unit 23 in the distributed code). When the system atoms
are read Lispf4 will write a message on unit lu (unit 5 in the code)
and start reading expressions from unit li (5 in the code). If everything 
works you should now be able to typ in forms and get them evaluated.
i.e you type (PLUS 6 7) after the prompter and lispf4 answers 13.


8.
Read those LISP-package you want to use.
To change standard input in the "scratch" system, use
   (IOTAB 1 unit)
You may choose between:
   BASIC1          (this one is necessary)
   BASIC2
   IO1
   FUNC1           DE, DF etc
   DEBUG1          BREAK,ADVISE, TRACE
   DEBUG1          BREAK1, error
   MAKEF           MAKEFILE
   EDIT            STRUCTURE EDITOR
 
You must ofcourse have assigned the files above to a unit in some
way before you try to read them.


9.
For convenience you may now save your system by doing
    (ROLLOUT unit)
 
This file must also some way have been assigned to unit.

10.
Next time you enter LISPF4 start with (ROLLIN unit).
 
11.
Or, if you want to, replace the subroutine INIT2 by CALL ROLLIN(unit)
and you have not to care about the SYS-atoms any longer.
 

Once more

compile all the code
somehow assign

    the file FLOSYS      to unit LUNSYS (variable you set in intit2)
    the terminal (input) to unit LUNINS            "--"
    the terminal (output)to unit LUNUTS            "--"
 
  optionally (but needed if you want to read lispcode or do a rollout)

     the file BASIC1     to unit X
              BASIC2     to unti Y
                .................

     some file (why not LISPROLL) to untin Z


     now you can read BASIC1 by doing (IOTAB 1 X) etc.
     or save the system by (rollout Z).

If your system allows dynamic opening of files you can change the
code in init2 so that lispf4 opens the file FLOSYS at runtime, in
this way you will not have to assingn the lunsys unit to the file. A
commented portion in the code shows how this can be done in DEC20
fortran.

In the same way you could of course open the terminal for input on LUNINS
and output on LUNUTS  if it is needed. This is not the case on DEC20.

You can also write the function OPENF so that it works on your machine
and then you don't have to assign any files before you run LISPF4. The
OPENF function is ducumented later in this paper. The distributed code
contains a dummy definition of this function. Code that shows how this 
function is implementet for DEC20 is also supplied.

Additional hints:
 
- The range for small integers (MAXINT-BIGNUM)/2 should not be too
small.  Make it > 1000.
 
- The routine GARB may call LISPF4 "recursively" in case of error.
This is done only in order to offer the user a nice error handling,
but if your OS checks (and prohibits) "recursive" calls in FORTRAN you
must either do it indirectly through an assembler routine or replace
the call by an "error-return" by locking the stacks and placing an
error code at the top of FSTACK.    
 
INTERNAL REPRESENTATIONS.
 
On the next page there is a picture over the most important areas and
pointers used by the system.  Pointers are marked with straight arrows
(--------> ) and the flow of character are marked with sparse arrows
( - - - - -> ).
 
Alpha numerical atoms:
 
Let us follow what will happen when the atom FOO is read and printed.
FOO is stored in RDBUFF by a previous FORTRAN-READ (with A1 format).
RDPOS points to "the next character to be read".
FOO is now inserted to ABUFF and escape characters are moved.  Before
being moved the character is used an an index in CHTAB to determine its
type.  A hash address is calculated and used as entry in HTAB.  Suppose
that FOO has not been read before.  After finding an empty place in HTAB
this place is updated to point to NATOMP and NATOMP is increased by one
(new atoms are stored consecutively).  Suppose that NATOMP had the old
value i.  The printname FOO is now stored in PNAME, JBP are
updated to point to the next empty character position in PNAME.
(Also printnames are stored consecutively starting from the bottom).
The starting address for the printname  is stored in PNP(i) and the
ending address+1 is stored in PNP(i+1).  A pointer to the atom NOBIND
is placed in CAR(i) and CDR(i) is set to NIL.  Finally the pointer
i is returned to the caller.
If later on FOO is to be printed, the print routine recognizes FOO as
an atom (the pointer value i is below NATOM).  The printname is
fetched using PNP(i) and PNP(i+1) and moved to the PRBUFF at position
PRTPOS.  While moving CHTAB is consulted to check if escape characters
(%) are needed.  When PRBUFF is filled up (PRTPOS > MARG) or if
terpri() is called, the line is printed using FORTRAN-WRITE with
format (1X,150A1).
 
Important arrays and pointers in LISP F4.
 
  Address space:                       Length = NATOM
 1                                           //                    MAXINT
 I---------------I-------------------I---------------I--------!-------I
NIL         NATOM  NFREEB      NFREET          BIGNUM      NUMADD
    atoms and           lists           real numbers    small integers
    strings
 
            RDBUFF  (read buffer)
           I- - - I------------------------------------I - - - - - I
           I      I          FOO                       I           I
           I- - - I------------------------------------I - - - - - I
            1      LMARGR    !                     MARGR      IOBUFF
   CHTAB                    RDPOS
 I-----I NBYTES              !
 I     I                     !
 I     I   consulting        !
 I     I<----------------->  !
 I     I                     !
 I-----I 1 !- - - - - - - - -!
           !
           !ABUFF   (print name buffer)
           I--------------------------------------------I
 i-------- IFOO                                         I
 i         I--!-----------------------------------------I
 i          ! ABUP1
 i          !
 i          !- - - - - - - - - - - - - - - - - - - - -!       JBP --!
 i                                                    !             !
 i <- hash address                                    !             !
 i                                                    !             !
 i  HTAB        CAR     CDR              PNP          !  PNAME      !
 i I----I    I-------I-------I          I---I      I--!-------------!-I
 i I    I 1  I       I       I NIL      I   I 1    I  !             ! I
 i I    I    I       I       I          I   I      I  ! printnames  ! I
 i I    I    I       I       I          I   I      I  !             ! I
 i I----I    I       I       I          I   I      I  !->FOO- -!    ! I
 ->I  -----i I-------I-------I          I---I      I     ! !   !    ! I
   I----I  i->NOBIND I  NIL  I  <- - -> I  --------------! !   !    ! I
   I    I    I-------I-------I  same    I---I      I       !   !    ! I
   I    I    I       I       I  index   I  ----------------!   !    ! I
   I    I    I       I       I          I---I      I           !    ! I
   I    I    I       I       I          I   I      I           !    ! I
   I    I    I       I       I          I   I      I   !- - - -!    ! I
   I    I    I       I       I NATOMP   I   I      I   !            ! I
   I    I    I---------------I          I   I      I   !            ! I
   I    I    I Unused atom   I          I   I      I   !          <-! I
   I    I    I space         I NATOM    I   I      I- -!- - - - - - - I
   I    I    I---------------I          I   I      I   ! real numbers I
   I    I    I       I       I NFREEB   I   I      I   !              I
   I    I<-! I       I       I          I   I      I---!---!----------I
   I    I  ! !       I       I          I   I          !   !    NPNAME
   I----I  ! I       I       I          I   INATOM+1   !  NUMBP
    // NHTAB I   free list   I NFREEP   I---I          !
  hash-      I   start       I           //            !
  table      I       I       I         byte address    !
             I       I       I         in PNAME        !
             I-------I-------I NFREET                  !
                                                       !
                          !- - - - - - - - - - - - - - !
                          !                 CHTAB
                          !                I-----I
                          !                I     INBYTES
                          !   consulting   I     I
                          ! <------------->I     I
                          !                I     I 1
                          !                I-----I
  PRBUFF  (print buffer)  !
 I------I--------------------------------I- - - - - - -I
 I      I                FOO             I             I
 I------I--------------------------------I- - - - - - -I
  1      LMARG            PRTPOS    MARG         IOBUFF
 
Small integers:
 
The address space NFREET + NATOM - MAXINT is reserved for small integers,
and they are stored in the list structures as pointers.  The numerical
value of a small integer is pointer-NUMADD.
 
Floating point numbers:
 
Real numbers are represented as pointers in the address space NFREET + 1
- BIGNUM.  The length of this range is NATOM.  The integers themselves
are stored consecutively as full word integers in PNAME starting form
the top and using NUMBP as "free real space pointer".  When no more
 
Strings:
 
do not have an entry in HTAB and that a pointer to the atom STRING is
stored in CAR(i).  ("" are removed from the printname by the read
routine and added if asked for by the print routine).
 
Substrings:
 
representing atoms and strings (1,NATOM).
CAR(substring) = SUBSTR
CDR(substring) = (sourcestring start . length)
Substrings do not have a  printname of it's own (and thus do not occupy
space in HTAB or PNAME).
 
Lists:
 
The variable NFREEP points to the free list.  After a compacting
garbage collection the free list is a consecutive list of cons cells
starting from NFREEP and growing backwards down to NFREEB.
 
ARRAYS are stored in a way similar to that of atoms and stings.
All array data are stored in the Fortran array PNAME.  Arrays are
referred to by pointers in the range (T+1,NATOM).  Every array
consists of three parts, each one of which may have zero length.
The details are as follows:
 
             (z is zero or more slack bytes.)
             (i,j,k,l are byte pointers into PNAME.)
 
x        = the array pointer value
CAR(x)   = LISPF4-ARRAY
CDR(x)   = NIL
PNP(x)   = i
PNP(x+1) = l
 
PNAME:
 ....(z j k (pointers) z (integers) z (f. p. n.)) ....
      !                !            !             !
      i                j            k             l
 
The three array parts all start on a word boundary.  By a word we
mean the basic storage cell for a data type.  (E.g. half machine
word, full machine word, double machine word, etc.).
 
By this means it is possible to call a Fortran subroutine with an
actual parameter consisting of an address to an array part if the
corresponding formal parameter is a properly typed array.  The
advantage of this method, instead of having pointer arrays, is that
we do not have to "unbox" and "box" numbers before and after calls
to e.g. numerical routines.  For further details see the description
of subroutine ARRUTL.
 
RECURSIVE PROGRAMMING IN FORTRAN.
 
The definition of the LISP F4 interpreter is highly recursive
and in this chapter we will explain how recursion has been programmed.
 
The stack:
 
There are two stacks for recursive calls of sub functions.  One stack
(named ASTACK) is used for saving values which are to be saved during
a recursive call.  The other stack (named FSTACK) is used to hold
return jump indicators, here represented as integers which are used in
a computed GOTO-statement.  Both ASTACK and FSTACK are physically
stored in the same vector STACK using IP and JP as stack-top pointers.
 
                 STACK
  NSTACK ----> ---------
               I  val  I
               I  val  I          part ASTACK
               I  val  I
       JP ---> I  val  I
               I       I
               I       I
               I       I
       IP ---> I  ret  I
               I  ret  I
               I  ret  I          part FSTACK
               I  ret  I
        1      ---------
 
Pushing and popping are done by the routines
 
        APUSH APUSH2 APUSH3
        APOP  APOP2  APOP3
        FPUSH
 
and sometimes (for efficiency) in line as in
        998 I = STACK(IP)
            IP = IP - 1
 
Recursive calls and returns:
 
All recursive functions are coded in the FORTRAN subroutine LISPF4.
That means that they are not subroutines themselves but just pieces of
FORTRAN code.
A call is performed by saving necessary values with APUSH (or APUSH2,
APUSH3) and by saving a return jump indicator with FPUSH.
After all this pushing follows an unconditional GOTO to the "function"
and the follows (normally) a statement with the same statement number
as indicated by IND, there the execution is to continue at return from
the calling function.  Saved values are the fetched by a proper number
of calls to APOP.
A return form a recursive function is done by GOTO 998 where the
indicator saved on FSTACK is popped and used in a computed GOTO-
statement leaving the program control to the caller.
 
N.b.
In order to give the user a change in case of stack overflow, we have
done the following:
Whenever the difference JP-IP becomes less than a preset value MIDDL,
MIDDL is divided by 2 and SYSERROR is called (which in turn normally
calls the break package).  When MIDDL has become too small RESET is
performed and MIDDL is reinitialized to its original value.
 
THE EVAL-APPLY SYSTEM.
 
Eval-apply and all SUBR's and FSUBR's are handled by (or called from)
the subroutine LISPF4 which is "the heart of the interpreter".
Calling format is
 
       CALL LISPF4(IND)
 
where IND = 1 means "this is the first call to LISPF4".
          = 2 means "restart the interpreter"

 
The top level loop is defined as
 
      lispx();
      error();
      reset();
 
where lispx() is a SUBR defined as
 
      loop:  print(eval(read())); go loop;
 
but may be redefined by the user.
 
Transmission of arguments:
 
The variables ARG, ARG2 and ARG3 are reserved to hold the first three
arguments to SUBR's.
In case of SUBRN (see below) and FSUBR arguments are pushed onto ASTACK
and the number of arguments are held in the variable IARGS.  The value
of a function is assigned to IRES before returning and IRES is
EQUIVALENCE:s to ARG.  (Sometimes an argument just passes through).
In addition the variable FORM holds the form currently under
execution.
 

               Variable bindings in  lispf4
 

LAMBDA, NLAMBDA and PROG variables are pushed onto the parameter
stack (the arrays JACK and JILL) in traditional manner.  This list
should be thought of as a simulated variable stack (and is used
implicitly by eval, apply, setq, etc.).
 

Lisf4 use a stack for bindings very much like interlisp.  Each slot
on the stack holds variable name and value. In the fortran code the
stack is made up of to arrayes JACK and JILL. At a given moment the
global variable ENV points to the position of the stack that is the
environment. A global variable TOPS points to the last used slot on
the stack.

When eval evaluates a variable it will first scan the stack starting
at ENV if no value is found it will then look in the value-cell
(i.e. CAR) of the atom and if there is no value there then there is
an error.  When we enter a function we must bind its lambdavariables
on the stack and when we leave the function we must restore the
stack as it was before.

To do this we bind variables in blocks on the stack. One block for
each function. These blocks must contain information to make it
possible to remove them when we leave a function. This information
is kept in the tops marker slots. For debugging (and also used
internaly) purpose we keep the form (i.e. usually function call) in
the bottom marker.  A picture of the stack after 2 function call is
showed below.  In the first block the variable (atom) FUM is bound
to -23 and the variable FOOBAR is bound to nil.

            JACK         JILL

                 top marker
ENV -->    -------------------------
           ! BAR       !   77      !
           ! FOO       !   88      !
           -------------------------
                 bottom marker
                 tops marker
           -------------------------
           ! FUM       !   -23     !
           ! FOOBAR    !   NIL     !
           -------------------------
                 bottom marker



     The bottom and top marker.

The top marker must hold information that makes it possible for us
to restore the stack after function call. JILL of the tops marker
points to the previous tops marker. This makes it possible to drop
the block by doing TOPS =: JILL(TOPS). We also must restore the
environment and JACK of the topmarker points to previous
environment. Thus we restore environment by doing ENV =: JACK(ENV).

But couldn't TOPS and ENV be the same? . No some functions don't
bind variables on the stack (SUBR and FSUBR). We also want to be
able to evaluate some forms in a environment that we manipulate
ourself.  A funarg expression would put it's bindings on the stack
but would let it's topmarker JACK (the environment pointer ) point
to 0 .

When we look for bindings on the stack we start in the block pointed
to by ENV. When we have searched that block we follow this block's
environment pointer (that's JACK) to the next block. When we find an
environment pointer that points to 0 we are ready.

When we leave a function we always drop the block on tops of the
stack.  If the function was one that binds variables on the stack we
also restore the environment.

The bottom marker holds in JACK a pointer to *FORM
and in JILL a pointer to the FORM


Lets look what the interpreter does when we evaluate a userdefined
function.
           The form is (FOO FIE FUM (SETQ BAR 77))
           FOO is defined  (DE FOO (X Y)(CONS X Y))


          LAMBDA and NLAMBDA case
          =====================
           1. Put bottom marker 
                 PREV := TOPS-1    ! we must rememer the previous block
                 JACK(TOPS) := *FORM
                 JILL(TOPS) := FOO FIE FUM (SETQ BAR 77)
                 TOPS := TOPS+1
           2. Find the lambdalist (X Y)
           3. Find arglist        (FIE FUM (SETQ BAR 77))
           4. Take first element in the lambda list
              put it in JACK(TOPS)
              take first element of arglist
              put it in JILL(TOPS)
              arglist := rest(arglist)
              lambdalist := rest(lambdalist)
              TOPS := TOPS+1
              repeat step 4 until arglist is empty.
              If the lambdalist becomes empty before
              the arglist someone has called a function
              with more arguments than the function can use.
              This is not what I call good programming but it's
              allowed in interlisp and therefore allowed in LISPF4.
              The extra arguments all get the name -*-.
              The extra arguments are evaluated so if the evaluation
              has side effects you could use this (miss)feature.

           5. Put the top marker 
                JILL(TOPS) := PREV

               Now we must evaluate all the arguments.
               At this time the bindings in this block
               are not in the environment so we can
               use JACK(TOPS) to something else.
               We temporary let JACK(TOPS) := JILL(TOPS)
               And we let JILL(TOPS) point to the argument
               under evaluation.

                The tops block now looks like this

                                                            !- TOPS (global
              !--  LINK,,LINK -------------------------!  <--     variable)
    link      !    -*- (SETQ BAR 77)                   ! link to
    to        !     Y  FUM                             ! argument
    prev.     !     X  FIE                             ! under
    block     !   *FORM (FOO FIE FUM (SETQ BAR 77))  <-! evaluation
              !
              !->  LINK,,LINK


 Now you call eval with each argument. When the argument is
evaluated
 its put in JILL(JILL(TOPS)) and JILL(TOPS) is increased with 1.
 When all arguments are evaluated we let JILL(TOPS) := JACK(TOPS)
 JACK(TOPS) := ENV, ENV := TOPS.

Then we call eval with the body of the function.



Representation of SUBR's and FSUBR's etc.
 
The type of a function (if not LAMBDA or NLAMBDA) is indicated by the
pointer value of the atom itself as seen in the following picture:
 
 NIL
I----------I----------I----------I----------I----------I----------I--...
 1       SUBR0      SUBR1      SUBR2      SUBR3      SUBRN      FSUBR
 
I                          SUBR's                      I FSUBR's    I
 
SUBR's with no arguments are numbered in the range 1-SUBR0 and so on
for SUBR1, SUBR2 and SUBR3.  In the range SUBR3+1 - SUBR we have
SUBR's with an indefinite number of arguments (as PLUS).  FSUBR's are
numbered in SUBR+1 - FSUBR.
These conventions make it easy for apply to determine the proper
argument actions and then jump to the corresponding code using the
pointer value of the atom in a computed GOTO.
(SUBR . f) or (FSUBR . f) in the case of FORTRAN coded lisp functions.
In practice getd(f) is used inline in eval-apply and does not
construct the list (SUBR . f), but as (SUBR . f) is a legal function
form, cases like ((SUBR . f) ...) are also taken care of.
 
Error handling:
 
Two classes of errors may occur in the system.
 
1.  Hard errors - reset() is called.
detected inside LISPF4) or perform CALL LISPF4(2) if detected by an
other subroutine (garb is the only subroutine that does this).

 
2.  Soft errors - syserror() is called.
All these errors jump to a place where a call to
 
          syserror(errno, fn, args, form)
 
is built up and sent to apply for further action.
RESET.  Normally SYSERROR is redefined in lisp to make use of the
break package after the message.
 
 
Though eval-apply works as given in appendix B not all help functions
are called but placed inline.  Moreover it does not recursively call
EVAL when the form to be evaluated is the last one in
- PROGN
- a LAMBDA body
- a COND or SELECT clause.
 
Especially as (LAMBDA (..) S) is quite a common expression this little
trick saves a lot of good stack storage when recursion digs down.
 
 
HOW TO ADD NEW SUBRs AND FSUBRs

There are two ways of adding Lisp functions to the interpreter. The
simplest way is to use XCALL(NO,ARGS); the other way is to add inline code
to the heart of the interpreter, i.e. LISPF4.

1. How to use XCALL

The SUBR XCALL is initially dummy defined to return NIL. However, it can
be used as a handle for calling Fortran subprograms form Lispf4. To do this
you have to add code to the Fortran function XCALL(NO,ARGS), by using the
NO as a 'code selector' and ARGS as a list of arguments to the new routine.
In your Lisp program you then must call XCALL with the NO and ARGS belonging
to the Fortran routine you wish to call. Note that XCALL normally has to
convert Lisp data types into Fortran data types before calling the external
routine, and vice versa when returning a value. 

Note:
If your routine calls the Lispf4 interpreter, you have to write inline code
in Lispf4, making use of recursion conventions.

2. How to add new SUBRs to the heart of Lispf4

Do the following:

a) Insert the function name in the file FLOSYS. The location of
the name is important. The functions are grouped after type and
number of arguments.  (the order is SUBRs with 0 args, SUBR 1
numerical arg, SUBR 1 non-numerical arg, SUBR 2 args, SUBR 3 args,
SUBR n args, FSUBRs). Place the name in the selected list in FLOSYS
and remember the number of the location.

b) Change the corresponding computed GOTO statement in LISPF4, by
inserting a new statement number for the new function. Note that
each group of build tin functions have their own computed goto in
LISPF4. The labels of these computed GOTOs correspond to the lists
in the file FLOSYS.  It is also recommened that you add a comment at
the computed GOTO with the name of the new function.

c) Put your piece of code somewhere. You may access the arguments to
the function through the Fortran variables ARG, ARG2, ARG3. TheY can
also be found on the stack JILL where the variable IARGS is equal to
the actual number of arguments. The first arg is in
jill(index),second in jill(index+1) etc.  Normal return is done by
assigning IRES to the result value and then doing GOTO 998. If your
function is a FSUBR you should return to 999 and not to 998 as these
functions reset whaterver stacks they use themself.  You must
ofcourse do that too. Look at AND to see how it is done.

Warning:  If you make use of CONS, MKNUM, or MATOM explicitly within
your new function (also in XCALL), you must save all references to
Lisp objects so that they can be found in case of garbage
collection. Be sure to always store pointers to Lisp objects you
want to keep in the Fortran variables TEMP1, TEMP2, TEMP3, ARG,
ARG1, or ARG2, because the garbage collection marking is done from
those variables.

ADVICES FOR SAVING SPACE IF YOUR COMPUTER IS A MINI.
 
- Do not use double buffering in I/O.
 
  Some operating systems gives a choice between single and double
  buffering as an option.  Use single!
 
- Rewrite some routines in assembler.
 
  Especially FORTRAN I/O is used in a very trivial manner, and is very
  easy to recode in assembler.  In many cases this will save a lot of
  program storage.
 
- Overlaying.
  The following routines never call each other directly or indirectly
  LISPF4 vs.  INIT1, INIT2.  (INIT2 ought to be replaced by a call to
  ROLLIN anyhow).
  (GARB MARKL REHASH ROLLIN ROLLOUT MOVE) vs.
  (LSPEX NCHARS EQUAL GET).
  But as the last list consists of very small routines only it is
  probably not worth overlaying.  However this list can be extended by
  the routines (IPRINT PRIN1 PRINAT TERPRI) if you remove the call to
  IPRINT and TERPRI from the routine GARB, rename GARB to GARB1 and
  define a small routine GARB which calls GARB1 and then does the
  IPRINT call.
  See also the cross reference listing given in appendix A.
 
- Removing code.
 
  a) In GARB.  Remove the parts that perform atom - bignumber and
  compacting gbc.  Also remove the recursive (inline) code for list
  marking and use MARKL only.
  Remove REHASH.
  This implies that ROLLIN/ROLLOU must read/write the entire list
  space and the hash table HTAB.
 
  b) In PRIN1.  Remove the parts that are active during pretty-print
  only.
 
COMMENTS ABOUT THE FORTRAN ROUTINES USED.
 
The FORTRAN routines are grouped in the following manner.  (See also
appendix A, where a cross reference listing is given).
 
1.  The "main" routine
    MAIN 
 
2.  Initiation routines.
    INIT1 INTI2
 
3.  The "heart" routine.
    LISPF4
 
4.  ROLLIN/OUT
    ROLLIN ROLLOU MOVE
 
5.  Garbage collection.
    GARB MARKL REHASH
 
6.  Input routines.
    IREAD RATOM SHIFT RDNUMB
 
7.  Output routines.
    PRIN1 PRINAT PRIFLO PRIINT TERPRI IPRINT
 
8.  Diverse help routines to LISPF4
    MATOM MKNUM MKREAL GETNUM GTREAL GETCHT SETCHT NCHARS
    LSPEX MESS XCALL
 
9.  Small routines, push and pop etc.
    APUSH APUSH2 APUSH3 APOP APOP2 APOP3 FPUSH CONS SUBST
    EQUAL GET GETPN COMPPN ARRUTL
 
10. I/O routines.
    LOPEN RDA1 RDA4 WRA1 WRA4 EJECT REW DUMPUT DUMPIN
    DMPIN2 DMPOU2 
 
11. Assembler routines.
    GETCH PUTCH 

12. Machine dependant routines that must be coded in
    assembler/fortran for each computer. These
    routines are supplied in a dummy format that does nothing
    byt you have to write them to get date, time open symbolic
    files e.t.c

    MDATE,MTIME,MSLFT,OPENF
 
1.      The "main" routines.
 
1.1 SUBROUTINE MAIN

The main object is:
      CALL INIT1
      CALL INIT2
      CALL LISPF4(1)
      CALL LSPEX
 
 
 
2.      Initiation routines.
 
2.1 SUBROUTINE INIT1
Here all machine depended variables are set. 
 
2.2 SUBROUTINE INIT2
This routine reads the file FLOSYS and sets up the character table,
the symbol table and the list-space memory.  Also some variables
corresponding to some LISP atoms are defined.  It is recommended that
INIT2 is replaced by a call to ROLLIN as soon as a working system is
generated.
 
3.      The "heart" routine.
 
3.1 SUBROUTINE LISPF4(IREE)
 
The eval-apply system and all FORTRAN coded LISP functions.
 
4.      ROLLIN/OUT.
 
4.1 SUBROUTINE ROLLIN(LUN)
 
Reads a file produced by ROLLOU from logical unit LUN.
If rollin is not possible NIL is returned otherwise the value is LUN.
If the size of any array has changed since the last ROLLOU a lot of
pointers must be updated.  This is done by the routine MOVE.
After reading, a new free list is constructed in the empty list space
and the atoms are "rehashed" using the routine REHASH in order to
establish a correct hash table.
Finally read and write buffers are cleared, REWIND LUN is performed
and LUN is returned as the value of ROLLIN.
 
4.2 SUBROUTINE ROLLOU(LUN)
 
The routine saves a binary pattern of the LISP memory to be used later
on (read by ROLLIN).
The following parts of the memory are written on logical unit LUN.
CINF(1-15)      The 18 first words in COMMON /A/.
                Used by ROLLIN to detect if rollin is
                possible.
IMESS(1-im)     All messages.
AREA(1-NAREA)   COMMON /B/ up to (and including) DREG(7).
PNAME(...)      Printnames.  Only used upper and lower parts.
PNP(...)        Printname pointers.  Only used lower parts.
CAR,CDR(...)    Only used lower(atoms) and upper(lists)
                parts.  The free list is not written.
BCOM(1-c)       COMMON /CHARS/.  (character variables).
CHTAB(1-nb)     The character translation table.
 
Before writing a compacting garbage collection is called in order to
save a lot of space and time by not writing the free list.
CINF(1-8) consists of those variables which must not be changed until
next ROLLIN.
CINF(9-15) are those local pointers which may be updated if the sizes
of arrays have been changed.
Help routines to do all writing are DMPOU2 and DUMPUT.
ROLLOU rewindes LUN before returning.
 
4.3 SUBROUTINE MOVE(DIFF,MIN,MAX)
 
Used by ROLLIN to add DIFF to pointers in the range MIN < p <= MAX.
Pointers p are taken from CAR,CDR and ARGS(1-10) where ARGS is
equivalent to ARG, ARG1, ARG2 etc. in COMMON /B/.
 
5.      Garbage collection.
 
5.1 INTEGER FUNCTION GARB(GBCTYP).
 
This is the routine responsible for garbage collection.  The kind of
gbc is indicated by GBCTYP:
 
        GBCTYP   action                           called from
        ------   ------                           -----------
        0        Normal gbc. List cells only.     CONS
        1        List compacting.                 ROLLOU
        2        Big numbers.                     MKNUM
        3        Big numbers and atoms.           MATOM, MKNUM, MKREAL
 
GARB may also have been called form LISPF4 (the LISP function
reclaim(gbctyp) ).
Here is a short description of the working behavior of the garbage
collector:
 
Step 1:
Mark active cells by negating CDR.  If big numbers gbc mark in the
vector PNP.  If atom gbc mark also in CDR of atoms (by temporarily
setting NFREEB = T + 1).
 
Step 2:
Select proper action depending on GBCTYP.
 
       0 goto step 7
       1 goto step 3
       2 goto step 5
       3 goto step 5
 
Step 3:
List compacting (GBCTYP = 1).
Move active CAR CDR to the top of free storage and unmark CDR.  Leave
new address  in CDR of moved cell.  Goto step 6.
 
Step 4:
Atom gbc (GBCTYP = 3).
Move active atoms to the lower part of atom space (lower CAR,CDR).
Leave new address in (negative) HTAB and unmark CDR.  Goto step 6.
 
Step 5:
Big numbers (GBCTYP = 2,3).
Move active numbers (marked in PNP) to the top of PNAME.  Leave new
address in old place in PNAME.  Reset PNP.  If GBCTYP = 2 then goto 6,
otherwise goto step 4.
 
Step 6:
Restore moved pointers (GBCTYP = 1,2,3).
 
Step 7:
Clear memory.
GBCTYP = 0,1    Construct a free list and return.
       = 2      Return.
       = 3      Rehash all saved atoms and return.
 
 
Marking active atoms and cells starts from:
- The COMMON variables ARG ARG2 ARG3 ALIST FORM TEMP1 TEMP2
      TEMP3 I1CONS I2CONS
- Current ASTACK (temporarily saved values).
- CAR and CDR of defined atoms.
 
In the marking phase, a list of all encountered arrays is built up.  The
list is headed by the variable ARRLST.  Then -CDR(ARRLST) points to the
next array etc., until we get to NIL.  The mark phase is finished by
four steps:
 
1.  If ARRLST = NIL then exit.
2.  S:= ARRLST;  ARRLST:=-CDR(S);  CDR(S):=-NIL.
3.  "Start marking from all pointers stored in the array S"
4.  Go to 1.
 
 
2 SUBROUTINE MARKL.

This is a non recursive marking routine used by GARB if local stack
inline code in GARB as it looks upon each cons cell twice.  But in
case of program space problems, you may use only MARKL and remove the
marking code in GARB.
The algorithm is described in Sc 67.
Treats arrays as in GARB.
 
5.3 SUBROUTINE REHASH.
The routine is used for constructing a new entry in HTAB for each
existing atom.  REHASH is called from ROLLIN and from GARB (when atom
gbc is asked for).
 
6.      Input routines.
 
6.1 FUNCTION IREAD(N).
 
(N is a dummy).
IREAD reads an S-expression into internal form.  (See also appendix B
where IREAD is defined in LISP).
It uses RATOM to read separate tokens such as atoms, numbers
parenthesises etc.
The value is a pointer to the constructed S-expression.
 
6.2 INTEGER FUNCTION RATOM(A,IOP).
 
Read by IREAD to read the next token from the input buffer RDBUFF.
(IOP = 1).
RATOM is also called from LISPF4 (IOP = 0).
RATOM classifies the token and returns a type (and a value in the
parameter A) as follows:
 
     token   returned value  returned in A
     -----   --------------  -------------
     atom          1            atom
      (            2            NIL
      )            3            NIL
      '            4            NIL
      .            5          the atom .
 
RATOM keeps < and > in a separate bracket stack and (if called from
IREAD) < or > are never seen but returned as ( or as a proper number
of )'s.
 
6.3 SUBROUTINE SHIFT(I).
 
Reads the next character from the input buffer RDBUFF (and reads a new
line into RDBUFF if necessary).   The character is returned in CHR and
the type of the character in CHT.  The table CHTAB is accessed with
the character value (range 1 - NBYTES) to determine the type.  (A list
of different types is given in LISPF4 - User guide).
 
If I = 1 at entry the previous CHR is stored in ABUFF (the buffer for
a printname given to MATOM).
 
If I = 3 at entry, the previous CHR belongs to a string under
construction and is stored in PNAME.
 
The escape character % is never returned by SHIFT but signals the next
character to be treated as a letter, digit, + or - sign (depending on
its type).
Normally SHIFT is called from RATOM (the flag IFLG2 =NIL) but
sometimes also from the code for unpack(x) in LISPF4 (IFLG2 = T).  If
called from unpack, characters are read from PRBUFF instead and all
characters are treated as if they were prefixed by a %.
 
6.4 INTEGER FUNCTION RDNUMB(INTG) OR
                           (FLO).

(This function does not exist in the code now. The parsing is done
inline in ratom.)
 
This routine is a scanner for a integer/floating point number with
the following syntax:
 
   number ::= sm ! smEsn
   s      ::= + ! - ! empty
   n      ::= d ! dn
   d      ::= 0 ! 1 ! 2 ! 3 ! 4 ! 5 ! 6 ! 7 ! 8 ! 9
   m      ::= n ! n. ! n.n ! .n
 
7.      Output routines.
 
7.1 SUBROUTINE PRIN1(S).
 
This is the routine which prints a S-expression.  The format of the
output is directed by SYSFLAG(i) as follows:
 
      SYSFLAG no      value      means
      ----------      -----      -----
         2            NIL        fast printing
                      T          pretty printing
         3            NIL        (QUOTE s) prints as (QUOTE s)
                      T          (QUOTE s) prints as 's
         5            NIL        Do not add % or "
                      T          Add % or " when so needed
                                 for correct read back.
                                 (This flag is checked by
                                  PRINAT).
                                 Only used during pretty-print.
         7            NIL        Do not begin a new line if
                                 the current expression will
                                 fit on line.
                      T          Begin a new line whenever a
                                 sublist is found unless it is
                                 the first (or sometimes second)
                                 sub-expression.
 
A definition of PRIN1 in LISP is given in appendix B.
 
7.2 SUBROUTINE PRINAT(X,NKW,JPOLD).
 
Prints an atom X or ... (if X = -1) or --- (if X = -2).
NKW is the number of '-s to be printed.
JPOLD is a saved stack pointer which is used to reset the stack in
case of error.
The printname is first stored in PRBUFF, then checked if it fits.
(That is why the size of the print buffer is twice maximum of a
printname).
If overflow has occurred TERPRI print the line up to the old print
position and then the printname for the atom is moved to the proper
position in PRBUFF.
For each character sent to PRBUFF a test by the routine GETCHT is
performed to check whether a % is needed or not.  This check is not
done if SYSFLAG(5) = NIL.
 
7.3 SUBROUTINE PRIFLO(F).
 
Prints the floating point number F.
 
7.4 SUBROUTINE PRIINT(I).
 
Prints the integer I.
 
7.5 SUBROUTINE TERPRI.
 
Writes PRBUFF on logical unit LUNUT and resets PRTPOS (the print
position) to LMARG (current left margin).  If called from NCHARS (the
flag IFLG1 is not = NIL) output is not printed but the numbers of
characters (= value of PRTPOS -1) is accumulated to IFLG1.
 
7.6 SUBROUTINE IPRINT(I).
 
         CALL PRIN1(I)
         CALL TERPRI
         RETURN
         END
 
8.      SOME AUXILIARY ROUTINES FOR LISPF4
 
8.1 FUNCTION MATOM(L).
 
At entry abs(L) character are stored in ABUFF.  If L > 0 MATOM
creates a atom.  Otherwise a sting is constructed.
If an atom with the same printname already exists, that atom is
returned as the value of MATOM; otherwise a new atom is created.  If
no more space for atoms are left a compacting atom garbage collection
is performed.
 
8.2 FUNCTION MKNUM(N).
 
N is a full word integer.
value of N.
 
8.3 SUBROUTINE MKREAL(R).
 
Stores a floating point number in upper PNAME and returns a LISP pointer
to it.
 
8.4 INTEGER FUNCTION GETNUM(I).
 
Returns the FORTRAN integer value of a  LISP number as an integer.
GETNUM converts real numbers to integers. The caller is responsible for
that I is a LISP number.
 
8.5 FUNCTION GTREAL(I,IRETUR).
 
pointer I.  IRETUR will contain the closest integer number.
 
If I points to a small integer, GTREAL will return 0.0 (but IRETUR
will still return the integer value).
 
8.6 INTEGER FUNCTION GETCHT(IC) AND SUBROUTINE SETCHT(IC,IT)
 
These routines are used for fetching/storing the internal type of a
character.  Calling format:
 
        I =GETCHT(IC)
        CALL SETCHT(IC,IT)
 
A character should be placed left justified in IC before calling.  The
integer value of that character is used as an index in the table
CHTAB.  The variable CHDIV is used to calculate this index by an
integer division.
with a new one (IT in SETCHT).
It is recommended to recode GETCHT and SETCHT in assembler.
(Or do this is some faster way than dividing)
 
8.7 INTEGER FUNCTION NCHARS(S,IFLG).
 
This routine is used by the LISP functions concat, pack, unpack and
nchars in order to create a printname representation in PRBUFF.  It is
done by saving the current print status (buffer and pointer) and
calling PRIN1 for each member in S (which is a list of S-expressions).
IFLG = T indicates that % is to be printed by PRIN1  when needed.
The flag IFLG1 is set to NUMADD (not NIL) to indicate to TERPRI that
IFLG1 (in order to count characters).
After calling NCHARS,
 
- concat   creates a string.  TERPRI builds the printnames from
           the print buffer.
- nchars   returns the number of characters.
- pack     creates an atom from the print buffer.
- unpack   creates a list of atoms by reading the print
           buffer character by character.
 
Before returning they must reset the print status.
 
8.8 SUBROUTINE LSPEX.
 
Exits from LISP F4 after writing statistical messages.  The exit is
done by the FORTRAN statement STOP. 
 
8.9 SUBROUTINE MESS(I).
 
If I = 0 then MESS was called from INIT2 and messages are read from
LUNSYS.  Otherwise a message corresponding to the no I is printed.
 
8.10 INTEGER FUNCTION XCALL(FN,L).
 
A dummy function (returns NIL) where you may add your own pieces of
FORTRAN codes such as calling oter subroutines.  Use FN as a selector
in a computed GOTO and L as the argument list.  FN is a FORTRAN
integer at calling.
 
9.      Small routines, push and pop etc.
 
9.1 PUSHING AND POPPING
 
The following subroutines handle ASTACK, the upper part of the array
STACK.  JP points to the current top.
 
   APUSH(I) APUSH2(I,J) APUSH3(I,J,K)
    APOP(I)  APOP2(I,J)  APOP3(I,J,K)
 
(Pushing and popping are done from left to right in the argument
lists).
The subroutine FPUSH(I) pushes a statement number indicator onto
FSTACK, the lower part of STACK.  Here IP points to the current top.
 
address is put onto FSTACK (which forces LISPF4 to jump to the reset
label at next recursive return.).
 
Remark:  In the eval-apply system pushing and popping are coded
inline.  At the entrance of eval there is a check whether the stack
space left is reasonable.
 
9.2 INTEGER FUNCTION CONS(I1,I2)
 
Does cons(I1,I2).
In case of an empty free list garbage collection is activated (GARB).
If the number of free cons cells is less than ISPLFT a weak error is
triggered (SYSERROR - break) and ISPLFT is divided by 2.
ISPLFT is reset to 400 whenever a RESET is performed.
 
9.3 INTEGER FUNCTION SUBST(IX,IY,IS).
 
Does subst(ix,iy,is).
 
(this function is now replaced with SUBPR (substitute pairs) that
is much more genrall) SUBST is then defined in one of the lisp-packges
in terms of subpair.


9.4 INTEGER FUNCTION EQUAL(II,JJ).
 
Does equal(ii,jj).
 
9.5 INTEGER FUNCTION GET(J,I).
 
Does get(j,i).
 
9.6 INTEGER FUNCTION GETPN(X,MAIN,JB,IPL).
 
  MAIN   = Pointer to main string if substring.
  JB     = Byte offset in printname.
  IPL    = Byte length of printname.
  GETPN  = -1  X is invalid.
            0  if X literal atom.
            1  if X string or substring.
 
9.7 INTEGER FUNCTION COMPPN(X,Y).
 
              returns:           if:
               -2                x is invalid
               -1                x < y
                0                x = y
                1                x > y
                2                y is invalid
 
9.8 SUBROUTINE ARRUTL(IPTR,IACTN,IPART,IFIRST,ILEN).
 
This routine performes various array handling functions.
IPTR is a pointer to the array, IPART tells which part of it (1,2,or
3), and IACTN tells what action to be done:
 
IACTN = 1  get array element IFIRST
        2  set array element IFIRST
        3  set IFIRST  and ILEN to array part bounds
 
array part and ILEN is the number of elements.
 
10.     I/O routines.
 
10.1 REMOVED

 
10.2 SUBROUTINE RDA1(LUN,CARD,I1,I2,IEOF).
 
Reads from logical unit LUN to the array CARD(I1-I2) using A1 format.
If end of file is found,IEOF is set to 2.
Used by SHIFT and INIT2.
 
10.3 SUBROUTINE RDA4(LUN,CARD I1,I2)
 
As RDA1 but uses format A4.  Used by MESS.
(or whatever format is a fullword  on your machine)
10.4 SUBROUTINE WRA1(LUN,LINE,I1,I2).
 
Writes LINE(I1-I2) on logical unit LUN using format (1X,150A1).
Used by TERPRI.
 
10.5 SUBROUTINE WRA4(LINE,I1,I2).
 
As WRA1 but uses format (1X,100A4).  Used by MESS.
 
10.6 SUBROUTINE EJECT(LUN).
 
Skip to next page by writing format (1H1) on LUN.
 
10.7 SUBROUTINE REW(LUN).
 
Does REWIND LUN.
 
10.8 SUBROUTINE DMPIN(LUN,AREA,START,STOP)
 
Reads AREA(START-STOP)/LINE(I1-I2) in binary format from logical unit LUN.
Used by ROLLIN.
 
10.9 SUBROUTINE DMPOUT(LUN,AREA,START,STOP)
 
Writes AREA(START-STOP)/LINE(I1-I2) in binary format on logical unit LUN.
Used by ROLLOU.
 
(the two routines dmbin2 and dmpou2 use integer*2 format, if
you use integers as lisppointers (i.e. in CAR and CDR arryes) these
routines can be the same as DMPIN and DMPOUT)
 
11.     Assembler routines.
 
11.1 GETCH AND PUTCH.
 
These routines are coded in assembler and used for moving bytes from/to
an array.  Calling format:
 
       CALL PUTCH(VEC,CH,I)
       Store a character CH at location I in the array VEC.
       CALL GETCH(VEC,CH,I)
 
The character in CH is left justified with space padding.
The array VEC behaves as a character array numbered 1,2,3... (1 = the
leftmost one).
 
11.2 MSLEFT
 
The time scheduling routine which is coded in assembler.
MSLEFT is only called from LISPF4, the LISP function clock().  Use
your own time routine, or skip it if you do not care about the
clock function. 
 
 
APPENDIX A
 
CROSS-REFERENCE LIST OF FORTRAN ROUTINES.
(this listing may be wrong and may not contain all routines
and may contain routines that are not included in this version.
This listing was produced on a computer with a program that does not
longer exist, and no one has bothered to change the listing)

Routine:    Calling:
 
MAIN        INIT1   INIT2/ROLLIN    LISPF4  (LSPEX)
INIT1       GETCH
INIT2       IREAD   RDA1    SETCHT  MESS
LISPF4      All routines but:
            INIT1   INIT2   MAIN     (These are not called)
            REHASH  DMPIN  DMPOUT   (These and the following
            DAMPIN  DAMPUT  RDA1      are only callled indirectly).
            RDA4    WRA1    WRA4
ROLLIN      MOVE    REHASH  REW     DMPIN  DMPOUT
ROLLOU      GARB    REW     DMPIN  DMPOUT
GARB        MARKL   MESS    IPRINT  PRIINT  REHASH
            ARRUTL
REHASH      GETCH
IREAD       RATOM   CONS    FPUSH   APUSH2  APOP2
RATOM       MATOM   MKNUM   MKREAL  CONS    SHIFT
SHIFT       LSPEX   MESS    GETCHT  RDA1    MATOM
RDNUMB      SHIFT   MKNUM   MKREAL
PRIN1       PRINAT  TERPRI  APUSH2  APUSH3  APOP2
            APOP3
PRINAT      PRIFLO  PRIINT  TERPRI  GETNUM  GTREAL
            GETCH   GETCHT  GETPN
PRIFLO      PRIINT
TERPRI      WRA1    PUTCH   MATOM
IPRINT      PRIN1   TERPRI
MATOM       GARB    PUTCH   GETCH
MKNUM       GARB    MESS    MKREAL
MKREAL      GARB
GETNUM      GTREAL
NCHARS      PRIN1   MKNUM   CONS    APUSH
LSPEX       IPRINT  MKNUM   CONS    MESS    TERPRI
MESS        RDA4    WRA4
XCALL
CONS        GARB
SUBST       CONS    APUSH   APOP    FPUSH
EQUAL       GTREAL  GETNUM  APUSH2  APOP2   COMPPN
GETPN       GETNUM
COMPPN      GETPN   GETCH
 
APPENDIX B
 
DEFINITION OF EVAL APPLY READ AND PRINT.

(The definition of eval-apply is not absolutely correct
as it is the definition of the old LISPF3 system that used a
A-list to keep variable bindings. This system use a stack instead.)
 
<DEFINEQ
<LISPF4
(LAMBDA (N)
        (PROG (EVALSW ERRFN ALIST *BACKTRACE *BACKTRACEFLG)
        (AND (EQ N 1) (PRINT "LISP F4 etc."))
        (RESET)
        (APPLY 'LISPX NIL)
        (ERROR 25 'LISPX NIL NIL>
<LISPX
(LAMBDA NIL
        (PROG NIL
         LOOP (PRINT (EVAL (READ)))
              (GO LOOP>
<EVAL
(LAMBDA (FORM)
        (COND ((OR (NUMBERP FORM) (STRINGP FORM)) FORM)
              ((ATOM FORM)
               <COND ((FORM_ON_ALIST?) (USE_BOUND_VALUE))
                     ((NEQ (CAR FORM) 'NOBIND) (CAR FORM))
                     (T (SETQ EVALSW T)
                        (SETQ ERRFN 'EVAL)
                        (EAPPLY (CAR FORM) (CDR FORM>
<APPLY
(LAMBDA (FN ARGS)
        (SETQ EVALSW NIL)
        (SETQ ERRFN 'APPLY)
        (SETQ FORM (CONS FN ARGS))
        (AND FN (EAPPLY FN ARGS>
<EAPPLY
(LAMBDA (FN ARGS)
        (COND ((LITATOM FN)
               <COND ((GETD FN) (APPLYFN2 (GETD FN) ARGS))
                     (T (ERROR 2 ERRFN FN FORM>)
              (T (APPLYFN2 FN ARGS>
<APPLYFN1
(LAMBDA (FN ARGS)
        (COND ((SUBRP FN) (AND EVALSW (SETQ ARGS (EVLIS ARGS)))
                          (SAPPLY FN ARGS))
              ((FSUBRP FN) (SAPPLY FN ARGS))
              (T (ERROR 2 ERRFN FN FORM>
<APPLYFN2
(LAMBDA (FN ARGS)
        (COND ((NLISTP FN) (ERROR 2 ERRFN FN FORM))
              (T (SELECTQ (CAR FN)
                   (LAMBDA (AND EVALSW (SETQ ARGS (EVLIS ARGS)))
                           (LAPPLY FN ARGS))
                   (NLAMBDA (LAPPLY FN ARGS))
                   ((SUBR FSUBR) (APPLYFN1 (CDR FN) ARGS))
                   (FUNARG (PUSH ALIST)
                           (SETQ ALIST (CADDR FN))
                           (SETQ RES (EAPPLY (CADR FN) ARGS))
                           RES)
                   (ERROR 2 ERRFN FN FORM>
<LAPPLY
(LAMBDA (FN ARGS)
        (AND *BACKTRACEFLG
             (SETQ *BACKTRACE (CONS FORM *BACKTRACE)))
        (PUSH_ARGS_ON_ALIST)
        (SETQ RES (EVLAST (CDDR FN)))
        (AND *BACKTRACEFLG
             (SETQ *BACKTRACE (CDR *BACKTRACE)))
        RES>
<SAPPLY
(LAMBDA (FN ARGS)
        (JUMP_TO_CODE_FOR_FN>
<GETD
(LAMBDA (FN)
        (CONS ((GETP FN 'FNCELL))
              ((SUBRP FN) (CONS 'SUBR FN))
              ((FSUBRP FN) (CONS 'FSUBR FN>
<ERROR
(LAMBDA (ERRORN FN ARGS FORM)
        (APPLY 'SYSERROR
                (LIST ERRORN FN ARGS FORM>
<SYSSEROR
(LAMBDA (ERRORN FN ARGS FORM)
        (ERRORMESS ERRORN)
        (PRIN1 FN)
        (PRIN1 '-)
        (PRINT ARGS)
        (RESET>
 
>
 
(PRINT '"LISP F4 READ -- 7 FEB 79")
(PRINT '(VERSION 0))
<DEFINEQ
<BRSTK
<LAMBDA (X)
        (RPLACA BRSTK (PLUS X (CAR BRSTK)))
        (COND ((ZEROP (CAR BRSTK))
               (SETQ FLG NIL)
               (SETQ BRSTK (CDRBRSTK)))
              ((MINUSP (CAR BRSTK)) (SETQ OB NIL>>
 
<READ-L
(LAMBDA (S1 SN)
        (PROG (X)
         L    (SETQ X (READ-V))
              (AND (EQ X '%)) (GO R))
              (AND (NULL S1)
                   <SETQ S1 (SETQ SN (LIST (READ-S X>
                   (GO L))
              (COND ((NEQ X '%)
                     (RPLACD SN (LIST (READ-S X)))
                     (SETQ SN (CDR SN))
                     (GO L)))
              (SETQ X (LIST X))
              (SETQ X (READ-L X X))
              (RPLACD SN
                      (COND ((AND (LISTP (CDR X))
                                  (NULL (CDDR X)))
                             (CADR X))
                            (T X)))
         R    (RETURN S1)))>
 
<READ-S
(LAMBDA (X)
        (SELECTQ X
          (%( (READ-L))
          (%) (BRSTK 1) NIL)
          (%' (BRSTK 1)
              (PROG1 (LIST 'QUOTE (READ-S (READ-V)))
                     (BRSTK -1)))
          X))>
 
<READ-V
(LAMBDA NIL
        (OR FLG (SETQ OB (RATOM)))
        (SELECTQ OB
          (%< (SETQ BRSTK (CONS 1 BRSTK)) '%( )
          (%> (SETQ FLG T) (BRSTK -1) '%) )
          (%( (BRSTK 1) OB)
          (%) (BRSTK -1) OB)
          OB))>
 
<*READ
<LAMBDA NIL
        (PROG (FLG OB (BRSTK (LIST 0)))
              (RETURN (READ-S (READ-V>>
 
>
(SETQQ READFNS (BRSTK READ-L READ-S READ-V *READ))
(SETQQ READCOMS "LISP F4 READ -- 7 FEB 79")
(SETQ READGENNR 0)
STOP
 
(PRINT '"LISP F4 PRINT .. 26 FEB 79")
(PRINT '(VERSION 0))
<DEFINEQ
<EDITFLAG
(LAMBDA NIL (SYSFLAG 7))>
 
<ESCAPEFLAG
(LAMBDA NIL (SYSFLAG 5))>
 
<LASTDEPTH
<LAMBDA (S)
        (PROG ((DEPTH LEVEL))
         L    (COND ((OR (GREATERP DEPTH (PRINTLEVEL))
                         (NLISTP S))
                     (RETURN (DIFFERECE DEPTH LEVEL)))
                    (T (SETQ DEPTH (ADD1 DEPTH))
                       (SETQ S (UNKWLASTELT S))
                       (GO L>>
 
<LINEBREAK
<LAMBDA (S)
        (COND ((NULL PPBREAK) (SPACES 1))
              (<AND (LISTP S)
                    (LITATOM (CAR S))
                    (EQUAL '(FSUBR . QUOTE) (GETP (CAR S) 'FNCELL>
               <SETQ OLDCOL
                     (LMARG (COND ((LESSP (NCHARS S) COMMENTLEN)
                                    COMMENTCOL)
                                  (T (TERPRI) (TERPRI) 10>
               (TAB (LMARG))
               (PPLAG NIL))
              <(AND (EQ 1ST 'PROG) (GREATERP I 1))
               (TAB (PLUS (LMARG)
                          (COND ((ATOM S) -5) (0>
              ((OR *LBEFORE (LISTP S)) (TAB (LMARG)))
              ((SPACES 1>>
 
<LMARG
(LAMBDA (X) (IOTAB 7 X))>
 
<MIN
(LAMBDA (X Y) (COND ((LESSP X Y) X) (T Y)))>
 
<PPFLAG
(LAMBDA L (APPLY 'SYSFLG (CONS 2 L)))>
 
<PRINT-A
(LAMBDA (A)
        (RPT *NKW '(PRIN1 "'"))
        (PRIN0 A (ESCAPFLAG)))>
 
<PRINT-L
(LAMBDA (S RP)
        (PROG (( I O)
               (LEVEL (ADD1 LEVEL))
               (LMARG (LMARG))
               (OLDCOL O)
               (1ST (CAR S))
               PPBREAK X)
              (RPT *NKW '(PRIN1 "'"))
              (PRIN1 (COND (RP "(")
                           ((AND (PPFLG)
                                 (GREATERP
                                   (SETQ RP (LASTDEPTH S))
                                   *MAXPAR))
                             "<")
                            (T (SETQ RP O) "(")))
              <COND ((PPFLAG)
                     <SETQ PPBREAK
                           (AND (LESSP LEVEL (PRINTLEVEL))
                                (OR (EDITFLAG)
                                    (GREATERP
                                      (PLUS (PRINTPOS)
                                            (NCHARS S))
                                      (RMARG>
                     (LMARG (MIN (PLUS -3 (RMARG))
                                 (ADD1 (PRINTPOS>
         L    (SETQ X (UNKWOTE (CAR S) T))
              (OR (ZEROP I) (LINEBREAK X))
              (PRINT-S X
                (AND (NULL (SETQ S (CDR S))) RP))
              (SETQ I (ADD1 I))
              <AND (PPFLG)
                   (EQ I 1)
                   (NLISTP 1ST)
                   (LESSP (PRINTPOS)
                          (WEIGH (LMARG) (RMARG) *WEIGHT 1))
                   (LMARG (ADD1 (PRINTPOS>
              (COND ((NULL S))
                    ((NLISTP S) (PRIN1 " . ") (PRINT-A S))
                    (EQ I (PRINTLENGTH)) (PRIN1 "---"))
                    ((GO L)))
              (SELECTQ RP
                (0 (PRIN1 ")"))
                (1 (PRIN1 ">"))
                NIL)
              (LMARG LMARG)
              (RETURN S)))>
 
<PRINT-S
<LAMBDA (S RP)
        (AND (EQ LEVEL (PRINTLEVEL)) (SETQ S '...))
        (COND ((NLISP S) (PRINT-A S) (SETQ *LBEFORE))
              (T (PRINT-L S
                    (SELECTQ RP ((0 NIL) RP) (SUB1 RP)))
                 (SETQ *LBEFORE T)
                 (SELECTQ OLDCOL
                   (0)
                   (PROG1 (SELECTQ
                            (LMARG OLDCOL)
                            (10 (TERPRI) (TERPRI))
                            NIL)
                          (PPFLAG T>>
 
<QFLAG
(LAMBDA NIL (SYSFLAG 3))>
 
<RMARG
(LAMBDA NIL (IOTAB 8))>
 
<TAB
(LAMBDA (X)
        (AND (GREATERP (PRINTPOS) (SUB1 X)) (TERPRI))
        (PRINTPOS X))>
 
<UNKWLASTELT
<LAMBDA (L)
        (PROG ((I O))
         L    (RETURN
                (COND ((NULL (CDR L)) (UNKWOTE (CAR L)))
                      ((EQ I (PRINTLENGTH)) '---)
                      (T (SETQ I (ADD1 I))
                         (SETQ L (CDR L))
                         (GO L>>
 
<UNKWOTE
(LAMBDA (S FLAG)
        (PROG NIL
              (SETQ *COUNT 0)
         L    (AND (QFLAG)
                   (LISTP S)
                   (EQ (CAR S) 'QUOTE)
                   (LISTP (CDR S))
                   (NULL (CDDR S))
                   (SETQ *COUNT (ADD1 *COUNT))
                   (SETQ S (CADR S))
                   (GO L))
              (AND FLAG (SETQ *NKW *COUNT))
              (RETURN S)))>
 
<WEIGH
(LAMBDA (X1 X2 W1 W2)
        (QUOTIENT
          (PLUS (TIMES X1 W1) (TIMES X2 W2))
          (PLUS W1 W2)))>
 
<*PRINT
(LAMBDA (X)
        (PROG ((COMMENTCOL
                 (QUOTIENT (TIMES 2 (RMARG)) 3))
               <COMMENTLEN (PLUS -20 (TIMES 2 (RMARG>
               (LEVEL 0)
               (OLDCOL 0)
               *COUNT *LBEFORE *NKW)
              (PRINT-S (UNKWOTE X T))
              (TERPRI)
              (RETURN X)))>
 
>
        (EDITFLAG ESCAPEFLAG LASTDEPTH LINEBREAK LMARG MIN PPFLAG PRINT-A
         PRINT-L PRINT-S QFLAG RMARG TAB UNKWLASTELT UNKWOTE WEIGH
         *PRINT)
(SETQQ PRINTVARS (*MAXPAR *WEIGHT))
(SETQQ PRINTCOMS "LISP F4 PRINT -- 26 FEB 79")
(SETQ PRINTGENNR 0)
(SETQQ *MAXPAR 3)
(SETQQ *WEIGHT 8)
STOP
 
APPENDIX C
 
LIST OF FUNCTIONS.
 
NAME(ARGS)                                  NAME(ARGS)
 
ABS(N)                                      ADDLIST(A L)
ADDPROP(A P V)                              ADD1(N)
ADVISE(FN WHEN WHERE WHAT)                  ALIST()
ALPHORDER(A B)                              AND L
APPEND(L1 L2)                               APPLY(FN L)
APPLYA(FN L AL)                             APPLYSTK(FN L POS)
APPLY*(FN . L)                              ASSOC(A L)
ATOM(S)
 
BINDENV('V)
BREAK 'L                                    BREAK0(FN WHEN COMS)
BREAK1('BRKEXPR 'BRKWHEN 'BRKFN 'BRKCOMS)
BREAK11(BRKEXPR BRKWHEN BRKFN BRKCOMS)
 
CAAAR(S)                                    CAADR(S)
CAAR(S)                                     CADAR(S)
CADDR(S)                                    CADR(S)
CAR(S)                                      CDAAR(S)
CDADR(S)                                    CDAR(S)
CDDAR(S)                                    CDDDR(S)
CDDR(S)                                     CDR(S)
CHTAB(A N)                                  CLOCK()
CLOSE(FILE)                                 CONCAT
COND(...)                                   CONS(S1 S2)
COPY(S)                                     CURFILE('FILE)
 
DE('FN 'ARGS . 'BODY)                       DEFINEQ 'L
DF('FN 'ARGS . 'BODY)                       DIFFERENCE(N1 N2)
DSORT(L)
 
EDITF('FN . 'EDCOM)                         EDITS(S EDCOM)
EJECT()                                     EQ(S1 S2)
EQUAL(S1 S2)                                ERRORB()
ERRORMESS(N)                                ERRORN()
ERRORSET(ERRORFORM ERRFLG)                  EVAL(S)
EVALA(S AL)                                 EVLIS(L)
EVSTK(S POS)                                EXIT()
 
FUNCTION('FN)
 
GCGAG(FLAG)                                 GENSYM()
GETD(FN)                                    GETINT(S FORM)
GO*('LAB)                                   GREATERP(N1 N2)
 
INUNIT(N)                                   IOTAB(N1 N2)
 
LAST(L)                                     LENGTH(L)
LESSP(N1 N2)                                LISPX()
LIST L                                      LISTP(S)
LITATOM(S)                                  LOAD(FILE)
 
MAKEFILE(FILE FLAG)                         MAP(L FN1 FN2)
MAPC(L FN1 FN2)                             MAPLIST L FN1 FN2)
MEMB(A L)                                   MEMBER(A L)
MINUS(N)                                    MINUSP(N)
MKATOM(S)                                   MKSTRING(S)
 
NCHARS(S)                                   NCONC(L1 L2)
NLISTP(S)                                   NTH(L N)
NULL(S)                                     NUMBERP(S)
 
OBLIST(A)                                   OPEN(FILE OPT N)
OPEN0(FILE INFLG BINFLG)                    OR L
OUTUNIT(N)
 
PACK(S FLAG)                                PLUS L
PP 'L                                       PRINT(S)
PRINTDEF(S)                                 PRINTL L
PRINTLENGTH(N)                              PRINTLEVEL(N)
PRINTL-SP L                                 PRINTPOS(N)
PRIN0(S ESCFLG PPFLG)                       PRIN1(S)
PRIN2(S)                                    PROG(...)
PROGN L                                     PROG1 L
PROMPTTEXT(TXT)
PUT(A P V)                                  PUTD(FN S)
PUTINT(S X FORM)
 
QUOTE('S)                                   QUOTIENT(N1 N2)
 
RATOM()                                     READ()
READC()                                     READPOS()
READVISE 'L                                 REBREAK 'L
RECLAIM(N)                                  REMOVE(A L)
REMPROP(A P)                                RESET()
RETURN(S)                                   REVERSE(L)
REWIND(N)                                   ROLLIN(N)
ROLLOUT(N)                                  RPLACA(S1 S2)
RPLACD(S1 S2)                               RPLSTRING(S1 N S2)
RPT(N S)                                    RPTQ(N 'S)
 
SASSOC(A L)                                 SAVEDEF(FN)
SELECTQ(...)                                SET(A S)
SETQ('A S)                                  SETQQ(A S)
SIGN(N)                                     SPACES(N)
STRALLOC(N C)                               STREQUAL(S1 S2)
STRINGP(S)                                  SUBPR(A B S)
SUBSTRING(S N1 N2)                          SUB1(N)
SYSERROR(ERRTYPE FN ARG FORM)               SYSFLAG(N)
 
TERPRI()                                    TIMES L
TRACE 'L
 
UNADVISE 'L                                 UNBREAK 'L
UNPACK(S FLAG)                              UNSAVEDEF(FN)
UNTRACE 'L
 
VIRGINFN(FN)
 
XCALL(FN L)
 
ZEROP(N)
 
APPENDIX D
 
REFERENCES.
 
Ha 75   A. Haraldsson:      "LISP-DETAILS.  INTERLISP 360/370."
                             DLU 75/9
Sc 67   H. Schon etc.       "An efficient machine independent
                             procedure for ..." CACM Aug 1967.
******FLOSOR      (AUX ROUTINES FOR INTERPRETER)
C***********************************************************************
C*                                                                     *
C*                           LISP F4 (FLOATING)                        *
C*                           -------                                   *
C*                                                                     *
C*       THE SYSTEM WAS WRITTEN BY    UPDATED BY                       *
C*       DR. MATS NORDSTROM           HANS ERIKSSON AND                *
C*                                    KRISTINA JOHANSSON               *
C*                                    DR. TORE RISCH                   *
C*       READER, PRINTER, ARRAYS, AND FLONUMS                          *
C*       WERE ADDED BY                MATS CARLSSON                    *
C*       THE STACK-VARIANT OF THE                                      *
C*       INTERPRETER WAS WRITTEN BY   JAAN KOORT                       *
C*                                                                     *
C*       UPMAIL                                                        *
C*       STUREGATAN 2A                                                 *
C*       S-752 23  UPPSALA                                             *
C*       SWEDEN                                                        *
C*                                                                     *
C*        THE WORK WAS SUPPORTED BY THE SWEDISH BOARD                  *
C*        FOR TECHNICAL DEVELOPMENT (STU) NO 76-4253.                  *
C*                                                                     *
C***********************************************************************
C*IBM SUPPLIED MACHINE CODE*      EXTERNAL BRSERV
      DATA ISTART /0/
C-- SET UP INTERRUPT HANDLER
C*IBM SUPPLIED MACHINE CODE*      CALL BRSET(BRSERV)
      CALL BRSET
      IF(ISTART.NE.0)GOTO 10
      CALL INIT1
      CALL INIT2
      ISTART=1
      CALL LISPF4(1)
      CALL LSPEX
      STOP
C-- IN CASE OF INTERRUPT AND RESTART THE VARIABLE ISTART
C-- TELLS IF WE HAVE DONE THE INIT, THEN WE CAN CALL THE INTERPRETER
C-- DIRECTLY
C-- ON COMPUTERS WHERE YOU SAVE CORE IMAGES (E.G. DEC20) YOU CAN
C-- START THE LISPF4 SYSTEM, READ ALL LISPCODE YOU WANT AND THEN
C-- EXIT AND SAVE THE CORE IMAGE. THIS WAY YOU DONT HAVE TO USE ROLLFILES
C-- 
10    CALL LISPF4(1)
      CALL LSPEX
      STOP
      END
C
      SUBROUTINE BRSERV
      INCLUDE 'F4COM.FOR'
C--  INTERRUPT HANDLER
      ERRTYP=26
      IBREAK=.TRUE.
      RETURN
      END
      SUBROUTINE APUSH(I)
      INCLUDE 'F4COM.FOR'
      JP=JP-1
      IF(IP .GE. JP) GO TO 2
      STACK(JP)=I
      RETURN
2     STACK(IP)=16
      JP=JP+1
      RETURN
      END
      SUBROUTINE APUSH2(I,J)
      INCLUDE 'F4COM.FOR'
      JP=JP-2
      IF (IP .GE. JP) GO TO 2
      STACK(JP+1)=I
      STACK(JP)=J
      RETURN
2     STACK(IP)=16
      JP=JP+2
      RETURN
      END
      SUBROUTINE APOP(I)
      INCLUDE 'F4COM.FOR'
      IF (JP .GT. NSTACK) GO TO 2
      I=STACK(JP)
      JP=JP+1
      RETURN
2     STACK(IP)=17
      JP=IP+1
      RETURN
      END
      SUBROUTINE APOP2(I,J)
      INCLUDE 'F4COM.FOR'
      IF (JP .GT. NSTACK) GO TO 2
      I=STACK(JP)
      J=STACK(JP+1)
      JP=JP+2
      RETURN
2     STACK(IP)=17
      JP=IP+1
      RETURN
      END
      SUBROUTINE APUSH3(I,J,K)
        INCLUDE 'F4COM.FOR'
      JP=JP-3
      IF (IP .GE. JP) GO TO 2
      STACK(JP+2)=I
      STACK(JP+1)=J
      STACK(JP)=K
      RETURN
2     STACK(IP)=16
      JP=JP+3
      RETURN
      END
      SUBROUTINE APOP3(I,J,K)
        INCLUDE 'F4COM.FOR'
      IF (JP .GT. NSTACK) GO TO 2
      I=STACK(JP)
      J=STACK(JP+1)
      K=STACK(JP+2)
      JP=JP+3
      RETURN
2     STACK(IP)=17
      JP=IP+1
      RETURN
      END
      SUBROUTINE FPUSH(I)
        INCLUDE 'F4COM.FOR'
      IP=IP+1
      IF (IP .GE. JP) GO TO 2
1     STACK(IP)=I
      RETURN
2     IP=IP-1
      STACK(IP)=16
      RETURN
      END
      SUBROUTINE FPOP(I)
        INCLUDE 'F4COM.FOR'
      I=STACK(IP)
      IP=IP-1
      RETURN
      END
      INTEGER FUNCTION CONS(I1,I2)
        INCLUDE 'F4COM.FOR'
      INTEGER GARB0
      IF (NFREEP .EQ. NIL) GO TO 3
      ICONS = NFREEP
      CONS = ICONS
      NFREEP=CDR(NFREEP)
C*SETC*      CALL SETCAR(ICONS,I1)
       CAR(ICONS)=I1 
C*SETC*      CALL SETCDR(ICONS,I2)
       CDR(ICONS)=I2 
      RETURN
3     CONS=GARB0(I1,I2)
      RETURN
      END
      INTEGER FUNCTION GARB0(I1,I2)
      INTEGER GARB
      INCLUDE 'F4COM.FOR'
C                                      PERFORM A FREE CELL GARB
3     I1CONS=I1
      I2CONS=I2
      I=GARB(0)
      ICONS=NFREEP
      GARB0 = ICONS
      NFREEP=CDR(NFREEP)
C*SETC*      CALL SETCAR(ICONS,I1CONS)
       CAR(ICONS)=I1CONS 
C*SETC*      CALL SETCDR(ICONS,I2CONS)
       CDR(ICONS)=I2CONS 
      IF (I .GT. ISPLFT) RETURN
      ISPLFT=ISPLFT/2
      IBREAK=.TRUE.
      ERRTYP=34
      RETURN
      END
      INTEGER FUNCTION SUBPR(IX,IY,IS)
        INCLUDE 'F4COM.FOR'
      INTEGER CONS,EQUAL
      INTEGER RES,S
      LOGICAL NLISTP
      EQUIVALENCE (RES,TEMP1),(S,TEMP2)
      NLISTP(IDUMMY) = IDUMMY.LE.NATOM .OR. IDUMMY.GT.NFREET
      S=IS
      CALL FPUSH(1)
C-- MEMB TEST OF S IN IX
5     J=IX
      K=IY
6     IF(NLISTP(J))GOTO 7
      IF(NLISTP(K))K=NIL
      IF(EQUAL(CAR(J),S).EQ.T)GOTO 8
      J=CDR(J)
      K=CDR(K)
      GOTO 6
7     IF(J.EQ.NIL.OR.J.NE.S)GOTO 10
C--   (SUBPAIR '(X Y . Z) '(A B C D E) '(X Y Z))=
C--     (A B C D E)
      RES=K
      GOTO 20
8     RES=CAR(K)
      GOTO 20
10    IF(S.GT.NATOM .AND. S.LE.NFREET) GOTO 30
16    RES=S
20    I=STACK(IP)
      IF (I.GT.3) GOTO 90
25    IP=IP-1
      GOTO (50, 35, 40),I
30    ICDR=CDR(S)
      CALL APUSH(ICDR)
      CALL FPUSH(2)
      S=CAR(S)
      GOTO 5
35    S=STACK(JP)
      STACK(JP)=RES
      CALL FPUSH(3)
      GOTO 5
40    CALL APOP(S)
      RES=CONS(S,RES)
      GOTO 20
50    SUBPR=RES
      RETURN
C             PDL OVERFLOW. LEAVE OFLO ADDRESS (16) IN F-STACK
90    RETURN
      END
      INTEGER FUNCTION EQUAL(II,JJ)
        INCLUDE 'F4COM.FOR'
      INTEGER COMPPN
      JPE=JP
      I=II
      J=JJ
10    IF (I.EQ.J) GOTO 50
      IF (I.LE.NATOM) GOTO 80
      IF (I.GT.NFREET) GOTO 70
      IF (J.LE.NATOM .OR. J.GT.NFREET) GOTO 60
C             I NOT EQ J. I AND J ARE LISTS
15    CALL APUSH2(I,J)
      I=CAR(I)
      J=CAR(J)
      GOTO 10
20    CALL APOP2(J,I)
      I=CDR(I)
      J=CDR(J)
      GOTO 10
50    IF (JP.LT.JPE) GOTO 20
51    EQUAL=T
      RETURN
60    JP=JPE
      EQUAL=NIL
      RETURN
C               I = NUMBER
70    IF (J.LE.NFREET) GOTO 60
      IF (GTREAL(I,IN) .NE. GTREAL(J,JN)) GOTO 60
      IF (IN.NE.JN) GOTO 60
      GOTO 50
C                                      I = LITERAL/STRING
80    IF (0.EQ.COMPPN(I,J)) GOTO 50
      GOTO 60
      END
      INTEGER FUNCTION GET(J,I)
        INCLUDE 'F4COM.FOR'
      IF (J.GT.NFREET) GOTO 40
      K = CDR(J)
8     IF (K.LE.NATOM .OR. K.GT.NFREET) GOTO 40
      IF (CAR(K).EQ.I) GOTO 20
12    K=CDR(K)
      K=CDR(K)
      GOTO 8
20    K=CDR(K)
      GET=CAR(K)
      RETURN
40    GET=NIL
      RETURN
      END
      INTEGER FUNCTION GETPN(X,MAIN,JB,IPL)
C-----
C     DECODES THE LITATOM/STRING/SUBSTRING X
C     MAIN   <-- POINTER TO MAIN STRING, IF SUBSTRING
C     JB     <-- BYTE OFFSET TO PRINTNAME
C     IPL    <-- BYTE LENGTH OF PRINTNAME
C     GETPN <-- -1 = X INVALID, 0 = LITATOM, 1 = STRING/SUBSTRING
C-----
        INCLUDE 'F4COM.FOR'
      INTEGER X,GETNUM
      IF (X.GT.NATOM) GOTO 9010
      JB = PNP(X)
      IPL = PNP(X+1) -JB
      MAIN = X
      IF (CAR(X).EQ.STRING) GOTO 9030
      IF (CAR(X).NE.SUBSTR) GOTO 9020
C                                      TAKE CARE OF THE SUBSTR CASE
      L = CDR(X)
      IF (L.GT.NFREET) GOTO 9010
      MAIN = CAR(L)
      IF (MAIN.GT.NATOM) GOTO 9010
      IF (CAR(MAIN).NE.STRING) GOTO 9010
      L = CDR(L)
      IF (L.GT.NFREET) GOTO 9010
      IF (CAR(L).LE.NFREET .OR. CDR(L).LE.NFREET) GOTO 9010
C                                      GET BYTE ADDR
      II = CAR(L)
      JB = PNP(MAIN) +GETNUM(II) -1
C                                      GET BYTE LENGTH
      II = CDR(L)
      IPL = GETNUM(II)
      GOTO 9030
C                                      EXITS.
9010  GETPN = -1
      RETURN
9020  GETPN = 0
      RETURN
9030  GETPN = 1
      RETURN
      END
      INTEGER FUNCTION COMPPN(X,Y)
C-----
C     COMPARES THE PRINTNAMES OF ITS ARGUMENTS
C     COMPPN <-- -2 IF X ILLEGAL;  <-- 2 IF Y IS ILLEGAL;
C            <-- -1 IF X < Y;      <-- 1 IF X > Y;
C            <--  0 IF X = Y;
C-----
        INCLUDE 'F4COM.FOR'
      INTEGER GETPN,X,Y
      COMPPN = -2
      IF (0.GT.GETPN(X,MAIN,JB,IPL)) RETURN
      COMPPN = 2
      IF (0.GT.GETPN(Y,MAIN,JB2,IPL2)) RETURN
      COMPPN = 0
      MIN = IPL
      IF (IPL.GT.IPL2) MIN = IPL2
      IF (MIN.EQ.0) GOTO 20
C                                      COMPARE BYTE BY BYTE
      DO 10 I = 1,MIN
         CALL GETCH(PNAME,ICH,JB)
         CALL GETCH(PNAME,JCH,JB2)
         IF (ICH.LT.JCH) GOTO 30
         IF (ICH.GT.JCH) GOTO 40
         JB = JB +1
10       JB2 = JB2 +1
20    IF (IPL-IPL2) 30,50,40
30    COMPPN = -1
      GOTO 50
40    COMPPN = 1
50    RETURN
      END
      INTEGER FUNCTION XCALL(FN,X)
        INCLUDE 'F4COM.FOR'
      INTEGER FN,X
      XCALL = NIL
      RETURN
      END
      SUBROUTINE ARRUTL(IPTR,IACTN,IPART,IFIRST,ILEN)
C----
C
C + TAKES CARE OF THE SYSTEM'S ARRAY HANDLING.
C   ARRAYS ARE REPRESENTED AS FOLLOWS:
C
C             +--------------+
C             !              !
C PNAME:...(Z * * (POINTERS) Z (INTEGERS) Z (REALS)) (NEXT ATOM)...
C          !    !                         !          !
C          !    +-------------------------+          !
C PNP:(IPTR)                                  (IPTR+1)
C
C CAR(IPTR) = ARRAY                    (BYTE POINTERS)
C CDR(IPTR) = NIL                      (Z = 0 OR MORE SLACK BYTES)
C
C + PARAMETERS:
C
C   IPTR       LISP POINTER TO ARRAY (AS ABOVE)
C
C   IACTN  = 1 GET ARRAY ELEMENT
C          = 2 SET ARRAY ELEMENT
C          = 3 SET IFIRST AND ILEN TO ARRAY PART BOUNDS
C          = 4 MAKE AN ARRAY PART, INITTED TO IFIRST
C
C   IPART  = 1 POINTER PART IS REFERRED TO
C          = 2 INTEGER PART
C          = 3 REAL PART
C
C   IFIRST:    ARRAY PART RELATIVE INDEX (IACTN = 1,2) OR
C              PNAME RELATIVE INDEX      (IACTN = 3,4)
C
C   ILEN:      PNAME RELATIVE INDEX TO VALUE (IACTN = 1,2) OR
C              NO. OF ELEMENTS IN PART (IACTN = 3,4)
C
C + NUMERIC ELEMENT VALUES ARE TRANSMITTED VIA IPNAME/PNAME
C
C-----
        INCLUDE 'F4COM.FOR'
      INTEGER*2 JPNAME(1)
      INTEGER IPNAME(1),LWORD(3),LLEN(3)
      EQUIVALENCE (JPNAME(1),IPNAME(1),PNAME(1))
      EQUIVALENCE (LWORD1,LWORD(1)),(LWORD2,LWORD(2)),(LWORD3,LWORD(3))
      EQUIVALENCE (LLEN1,LLEN(1)),(LLEN2,LLEN(2)),(LLEN3,LLEN(3))
      MKJBP(IDUMMY,IDUMMZ) = ((JBP +IDUMMZ -2) /IDUMMZ +IDUMMY)
     *                        *IDUMMZ +1
C
      IF (IBREAK) GOTO 9000
C                                      CHECK PARAMETER IPTR
      IF (IPTR.LT.NIL .OR. IPTR.GT.NATOM) GOTO 8010
      IF (CAR(IPTR).NE.ARRAY) GOTO 8010
C                                      GET ARRAY BOUNDS
      LBYTE1 = PNP(IPTR)
      LBYTE1 = IABS(LBYTE1)
      LWORD1 = (LBYTE1-2)/JBYTES +4
      IF (IACTN.EQ.4 .AND. IPART.EQ.1) GOTO 4000
      LBYTE2 = JPNAME(LWORD1-2)
      LLEN1 = (LBYTE2-LBYTE1)/JBYTES -2
      IF (IPART.LT.2) GOTO 20
      LWORD2 = (LBYTE2-2)/IBYTES +2
      LBYTE3 = JPNAME(LWORD1-1)
      LLEN2 = (LBYTE3-LBYTE2)/IBYTES
      IF (IPART.LT.3) GOTO 20
      LWORD3 = (LBYTE3-2)/BYTES +2
      LLEN3 = PNP(IPTR+1)
      LLEN3 = (IABS(LLEN3) - LBYTE3)/BYTES
20    GOTO (1000,2000,3000,4000), IACTN
C
C GET ARRAY ELEMENT (CALLED BY ELT,ELTI,ELTR)
C
1000  IF (IFIRST.LE.0 .OR. IFIRST.GT.LLEN(IPART)) GOTO 8020
      ILEN = LWORD(IPART)+IFIRST -1
      GOTO 9000
C
C SET ARRAY ELEMENT (CALLED BY SETA,SETI,SETR)
C
2000  IF (IFIRST.LE.0 .OR. IFIRST.GT.LLEN(IPART)) GOTO 8020
      IND = LWORD(IPART) +IFIRST -1
      IF (IPART.EQ.1) JPNAME(IND) = JPNAME(ILEN)
      IF (IPART.EQ.2) IPNAME(IND) = IPNAME(ILEN)
      IF (IPART.EQ.3)  PNAME(IND) =  PNAME(ILEN)
      GOTO 9000
C
C GET ARRAY BOUNDS (CALLED BY ARRAYSIZE AND GARB (STEPS 1,6))
C
3000  IFIRST = LWORD(IPART)
      ILEN = LLEN(IPART)
      GOTO 9000
C
C MAKE AN ARRAY (CALLED BY ARRAY AND GARB (STEP 4))
C REQUIRES THAT WE HAVE ENSURED THAT THERE IS ENOUGH SPACE ALREADY
C IFIRST = 0 YIELDS DEFAULT VALUES IN THE NEW ARRAY
C
4000  JFIRST = IFIRST
      GOTO (4100,4200,4300), IPART
C PTR PART
4100  JBP = MKJBP(ILEN+2,JBYTES)
      IF (ILEN.EQ.0 .OR. LWORD1.EQ.JFIRST) GOTO 4410
      DO 4150 J = 1,ILEN
         IF (JFIRST.EQ.0) GOTO 4120
         JPNAME(LWORD1) = JPNAME(JFIRST)
         JFIRST = JFIRST+1
         GOTO 4150
4120     JPNAME(LWORD1) = NIL
4150     LWORD1 = LWORD1+1
      GOTO 4410
C INT PART
4200  JBP = MKJBP(ILEN,IBYTES)
      IF (ILEN.EQ.0 .OR. LWORD2.EQ.JFIRST) GOTO 4420
      DO 4250 J = 1,ILEN
         IF (JFIRST.EQ.0) GOTO 4220
         IPNAME(LWORD2) = IPNAME(JFIRST)
         JFIRST = JFIRST+1
         GOTO 4250
4220     IPNAME(LWORD2) = 0
4250     LWORD2 = LWORD2+1
      GOTO 4420
C REAL PART
4300  JBP = MKJBP(ILEN,BYTES)
      IF (ILEN.EQ.0 .OR. LWORD3.EQ.JFIRST) GOTO 4430
      DO 4350 J = 1,ILEN
         IF (JFIRST.EQ.0) GOTO 4320
         PNAME(LWORD3) = PNAME(JFIRST)
         JFIRST = JFIRST+1
         GOTO 4350
4320     PNAME(LWORD3) = 0.
4350     LWORD3 = LWORD3+1
      GOTO 4430
C                                      SET THE POINTERS
4410  LWORD1 = LWORD1-ILEN
      JPNAME(LWORD1-2) = JBP
4420  JPNAME(LWORD1-1) = JBP
4430  PNP(IPTR+1) = JBP
      GOTO 9000
C                                      EXITS
C ARG NOT ARRAY
8010  IBREAK = .TRUE.
      ERRTYP = 21
      GOTO 9000
C ARRAY INDEX OUT OF BOUNDS
8020  IBREAK = .TRUE.
      ERRTYP = 28
      ARG = ARG2
9000  RETURN
      END
      SUBROUTINE INIT1
        INCLUDE 'F4COM.FOR'
C             AFTER CALLING INIT1 YOU MAY CALL ROLLIN INSTEAD OF INIT2
C             THE FOLLOWING VARIABLES ARE MACHINE DEPENDENT AND ARE TO BE
C             SET BY THE IMPLEMENTOR OF LISPF4
      NATOM=3000
      NFREET=28000
      NSTACK=1500
      NHTAB=4000
      NPNAME=5000
      HILL=1500
      JBYTES = 5
      IBYTES = 5
      BYTES=5
      LUNIN=5
      LUNUT=5
      LUNSYS=23
      MAXLUN=99
      IOBUFF=160
      NBYTES = 128
      CHDIV=536870912
C          =2**29
      MAXBIG=34359738367
C           =2**35-1
      MAXINT=MAXBIG
      IRESOL = 8
      IPOWER = 50
      FUZZ = 5.E-8
C THE NEAREST 10**N LOWER THAN MAXBIG
      RMAX=10**(IFIX(ALOG10(FLOAT(MAXBIG)))-1)
C
C             THE FOLLOWING VARIABLES BELONGS TO INIT1 BUT MAY NOT
C             BE CHANGED BY VARIOUS IMPLEMENTATIONS
      NIL=1
      NBMESS = 40
      MAXMES = 40
      NCHTYP = 26
      NAREA=82
C               NAREA = THE LENGTH OF COMMON /B/ FROM ARG TO DREG(7)
      NFREEB=NATOM+1
      LUNINS=LUNIN
      LUNUTS=LUNUT
      BIGNUM=NFREET+NATOM
      ISMALL = (MAXINT-BIGNUM-1)/2
      NUMADD = MAXINT-ISMALL
      DPNP=NPNAME-NATOM
      DPNAME=DPNP-NFREET
      BIGMAX = FLOAT(MAXBIG)
C                   NOW FOLLOW VARIABLE SETTINGS THAT
C                   ONLY HAVE TO BE DONE ONCE PER RUN.
C STACK
       STACK(1)=17
C PNP
      DO 10 I = 1,NATOM
10       PNP(I) = 1
      GARBS=0
      CGARBS=0
      AGARBS=0
      NGARBS = 0
      RETURN
      END
      SUBROUTINE INIT2
        INCLUDE 'F4COM.FOR'
C             ALL MACHINE INDEPENDENT INITIALIZATIONS ARE DONE HERE
C             INIT2 MAY BE REPLACED BY A CALL TO ROLLIN
C
      INTEGER SYSAT,ICH(26),ISYS(7),ARGS(10),ISYS2(22)
      EQUIVALENCE (SPACE,ICH(1)),(SUBR0,ISYS(1)),(ARG,ARGS(1))
      EQUIVALENCE (A000,ISYS2(1))
      NATOMP=0
      IP=1
      JP=NSTACK+1
        JBP=1
        NUMBP=NPNAME+1
        ABUP1=0
      LMARGR=1
      LMARG=1
      MARGR = 80
      MARG = 80
      LEVELL = 1000
      LEVELP = 1000
      MAXPAR = 3
      ITABWG = 8
      MIDDL=NSTACK/10
      UNUSED=-1001
C
C      BELOW IS CODE THAT OPENS SYSATOMS AT RUNTIME SO YOU DON'T NEED
C      TO ASSIGN IT.
C
C      OPEN(UNIT=LUNSYS ,NAME='DSK:FLOSYS.LSP',ERR=3)
C      GOTO 4
C3     WRITE(LUNUTS,5)
C5     FORMAT(1X,20HCANT'T OPEN SYSATOMS)
C      STOP
C
C
C
C             READ SYSTEM CHARACTERS
      CALL RDA1(LUNSYS,ICH,1,NCHTYP,IEOF)
C
C
C
CDEBUG      WRITE(LUNUTS,29)(ICH(IIII),IIII=1,26)
CDEBUG29    FORMAT(' ICH=',26A1)
C             READ  ()<>"'..T+-0123456789%^E#
C             IF YOU GOT THE BCD-CODED VERSION, YOU MUST REPLACE THE
C             CHARACTERS FOR PROCENT, LEFT-BRACKET, RIGHT-BRACKET BY
C             SOMETHING ELSE
C
C             CLEAR HTAB
      DO 30 I=1,NHTAB
30    HTAB(I)=UNUSED
C
C             CLEAR CAR AND CDR AND MAKE FREE LISTS
      NFREEP=NIL
      DO 180  I=NFREEB,NFREET
C*SETC*      CALL SETCAR(I,NIL)
       CAR(I)=NIL 
C*SETC*      CALL SETCDR(I,NFREEP)
       CDR(I)=NFREEP 
180   NFREEP=I
C             INITIALIZE CHTAB
      DO 200 I=1,NBYTES
200   CHTAB(I)=10
C             PUT CHARACTER TYPES IN CHTAB
      DO 220 I = 1,NCHTYP
220      CALL SETCHT(ICH(I),I)
      DO 225 I=1,IOBUFF
      BUFF(I) = SPACE
      RDBUFF(I) = SPACE
      PRBUFF(I) = SPACE
225   ABUFF(I)=SPACE
      PRTPOS=1
      RDPOS=1000
      CHT=1
C
      NARGS=10
      NUMGEN = 0
      DO 250 I=1,7
250   DREG(I)=NIL
      IFLG1=NIL
      IFLG2=NIL
      DO 260 I=1,NARGS
260   ARGS(I)=NIL
C             USE LISP READ FUNCTION TO READ LISTS OF FUNCTION NAMES
C             FROM LUNSYS THUS CREATING ATOMS FOR THE SYS-FUNCTIONS
C
C             THE INTERVALS SUBR0 - FSUBR ARE EQUIVALENCE TO ISYS
C
C             SUBR0 = LAST FUNCTION WITH 0 ARGS
C             SUBR11= LAST FUNCTION WITH 1 NUMERICAL ARG
C             SUBR1 = LAST FUNCTION WITH 1 ARG (MAY NOT BE NUM ARG)
C             SUBR2 = LAST FUNCTION WITH 2 ARGS
C             SUBR3 = LAST FUNCTION WITH 3 ARGS
C             SUBR  = LAST FUNCTION WITH N ARGS
C             FSUBR= LAST FSUBR
      LUNIN=LUNSYS
      DO 270 I=1,7
      ICAR = IREAD(0)
      ISYS(I)=NATOMP
CDEBUG      WRITE(LUNUTS,500)NATOMP
CDEBUG500   FORMAT(' NATOMP =',I4)
CDEBUG      WRITE(LUNUTS,501)(PNAME(IIII),IIII=1,20)
CDEBUG501   FORMAT(4(' PNAME ',5A5,/))
270   CONTINUE
C             DEFINE SOME ATOM-INDEX SEPARATELY
      DO 275 I = 1,22
275      ISYS2(I) = IREAD(0)
      LUNIN=LUNINS
C                                      SET CAR OF ATOMS
      DO 280 I = NIL,NATOMP
C*SETC*280      CALL SETCAR(I, UNBOUN)
280      CAR(I)= UNBOUN 
C*SETC*      CALL SETCAR(NIL,NIL)
       CAR(NIL)=NIL 
C*SETC*      CALL SETCAR(T,T)
       CAR(T)=T 
C             INITIALIZE MESS (HAVE MESS TO READ MESSAGES FROM LUNSYS)
      CALL MESS(0)
      RETURN
      END
      INTEGER FUNCTION ROLLIN(LUN)
        INCLUDE 'F4COM.FOR'
      INTEGER CINF(15),AREA(1),ACOM(8),BCOM(26)
      INTEGER*2 JPNAME(6006)
      EQUIVALENCE
     * (NATOPO,CINF(9)),
     * (NFREPO,CINF(10)),
     * (JBPO  ,CINF(11)),
     * (NUMBPO,CINF(12)),
     * (NFRETO,CINF(13)),
     * (NUMADO,CINF(14)),
     * (NPNAMO,CINF(15))
      EQUIVALENCE(ARG,AREA(1)),(NAREA,ACOM(1)),(SPACE,BCOM(1))
      EQUIVALENCE (JPNAME(1),PNAME(1))
      INREAL = BYTES/JBYTES
      CALL DMPIN(LUN,CINF,1,15)
C             CHECK IF ROLLIN POSSIBLE
      DO 1 I = 1,8
      IF(CINF(I) .NE. ACOM(I)) GOTO 90
1     CONTINUE
C               ATOM SPACE
      IF(NATOPO+1 .GE. NATOM) GOTO 90
C               PRINT NAMES AND FLOATING NUMBERS
      IF((JBPO-2)/BYTES+2+NPNAMO-NUMBPO .GE. NPNAME) GOTO 90
C               FREE STORAGE
      IF(NFRETO-NFREPO .GE. NFREET-NFREEB) GOTO 90
C               ROLLIN POSSIBLE, MOVE POINTERS AND READ.
      IDIFF1=NFREET-NFRETO
      IDIFF2=NUMADD-NUMADO
      NATOMP=NATOPO
      NFREEP=NFREPO+IDIFF1
      JBP=JBPO
      NUMBP=NUMBPO+NPNAME-NPNAMO
      CALL DMPIN(LUN,IMESS,1,NBMESS/IBYTES *MAXMES)
      CALL DMPIN(LUN,AREA,1,NAREA)
C                                      STACK IS USED PRIOR TO RESET.
      IP=1
      JP=NSTACK+1
      CALL DMPIN2(LUN,JPNAME,1,(JBP-2)/JBYTES+1)
      CALL DMPIN2(LUN,JPNAME, (NUMBP-1)*INREAL+1, NPNAME*INREAL)
      CALL  DMPIN2(LUN,PNP,1,NATOMP+1)
C*SETC*      CALL  DMPIN2(LUN,CARCDR,NIL,NATOMP)
      CALL  DMPIN2(LUN,CAR,NIL,NATOMP)
C*SETC*C
      CALL  DMPIN2(LUN,CDR,NIL,NATOMP)
C*SETC*      CALL  DMPIN2(LUN,CARCDR,NFREEP+1,NFREET)
      CALL  DMPIN2(LUN,CAR,NFREEP+1,NFREET)
C*SETC*C
      CALL  DMPIN2(LUN,CDR,NFREEP+1,NFREET)
      CALL DMPIN(LUN,BCOM,1,NCHTYP)
      CALL  DMPIN2(LUN,CHTAB,1,NBYTES)
C
C             CHECK IF WE NEED TO MOVE POINTERS
C
      IF (IDIFF1.GE.0) GOTO 22
C      CALL FTYPE('MOVING 1')
      CALL MOVE(IDIFF1,NFREEP-IDIFF1,BIGNUM-IDIFF1)
22    IF (IDIFF2.EQ.0) GOTO 24
C      CALL FTYPE('MOVING 2')
      CALL MOVE(IDIFF2,BIGNUM-IDIFF2,MAXINT)
24    IF (IDIFF1.LE.0) GOTO 30
C      CALL FTYPE('MOVING 3')
      CALL MOVE(IDIFF1,NFREEP-IDIFF1,BIGNUM-IDIFF1)
C
C     MAKE FREE LIST
C
30    MAX=NFREEP
      NFREEP=NIL
      DO 35 I=NFREEB,MAX
C*SETC*      CALL SETCAR(I,NIL)
       CAR(I)=NIL 
C*SETC*      CALL SETCDR(I,NFREEP)
       CDR(I)=NFREEP 
35    NFREEP=I
C
C             REHASH THE ATOMS
C
      CALL REHASH
C
C               CLEAR BUFFERS
      DO 60 I=1,IOBUFF
      ABUFF(I)=SPACE
      BUFF(I)=SPACE
      RDBUFF(I)=SPACE
      PRBUFF(I)=SPACE
60    CONTINUE
      PRTPOS=1
      RDPOS=1000
      CHT = 1
      ABUP1=0
      ROLLIN=LUN+NUMADD
      GOTO 91
90    ROLLIN=NIL
91    CALL REW(LUN)
      RETURN
      END
      SUBROUTINE ROLLOU(LUN)
        INCLUDE 'F4COM.FOR'
      INTEGER GARB,CINF(15),AREA(1),BCOM(26)
      INTEGER*2 JPNAME(6006)
      EQUIVALENCE (NAREA,CINF(1)),(ARG,AREA(1)),(SPACE,BCOM(1))
      EQUIVALENCE (JPNAME(1),PNAME(1))
      INREAL = BYTES/JBYTES
C             CALL COMPACTING GBC
      I = GARB(1)
      CALL DMPOUT(LUN,CINF,1,15)
      CALL DMPOUT(LUN,IMESS,1,NBMESS/IBYTES *MAXMES)
      CALL DMPOUT(LUN,AREA,1,NAREA)
      CALL DMPOU2(LUN,JPNAME,1,(JBP-2)/JBYTES+1)
      CALL DMPOU2(LUN,JPNAME, (NUMBP-1)*INREAL+1, NPNAME*INREAL)
      CALL DMPOU2(LUN,PNP,1,NATOMP+1)
C*SETC*      CALL DMPOU2(LUN,CARCDR,NIL,NATOMP)
      CALL DMPOU2(LUN,CAR,NIL,NATOMP)
C*SETC*C
      CALL DMPOU2(LUN,CDR,NIL,NATOMP)
C*SETC*      CALL DMPOU2(LUN,CARCDR,NFREEP+1,NFREET)
      CALL DMPOU2(LUN,CAR,NFREEP+1,NFREET)
C*SETC*C
      CALL DMPOU2(LUN,CDR,NFREEP+1,NFREET)
      CALL DMPOUT(LUN,BCOM,1,NCHTYP)
      CALL DMPOU2(LUN,CHTAB,1,NBYTES)
      CALL REW(LUN)
      RETURN
      END
      SUBROUTINE MOVE(DIFF,MIN,MAX)
        INCLUDE 'F4COM.FOR'
      INTEGER DIFF,ARGS(10)
      EQUIVALENCE (ARG,ARGS(1))
C
C             USED BY ROLLIN TO ADD DIFF TO POINTERS POINTING
C             IN (.GT.MIN , .LE.MAX)
      I1=NIL
      I2=NATOMP
      DO 20 J=1,2
      DO 10 I=I1,I2
C*SETC*      IF(CAR(I).GT.MIN.AND.CAR(I).LE.MAX) CALL SETCAR(I,CAR(I)+DIFF)
      IF(CAR(I).GT.MIN.AND.CAR(I).LE.MAX)  CAR(I)=CAR(I +DIFF)
C*SETC*      IF(CDR(I).GT.MIN.AND.CDR(I).LE.MAX) CALL SETCDR(I,CDR(I)+DIFF)
      IF(CDR(I).GT.MIN.AND.CDR(I).LE.MAX)  CDR(I)=CDR(I +DIFF)
10    CONTINUE
      I1=NFREEP
20    I2=NFREET
      DO 50 I=1,NARGS
      IF(ARGS(I) .GT. MIN.AND.ARGS(I).LE.MAX) ARGS(I)=ARGS(I)+DIFF
50    CONTINUE
      RETURN
      END
      SUBROUTINE PRIN1(S)
        INCLUDE 'F4COM.FOR'
C-----
C
C     THE GENERAL PRINT ROUTINE
C
C-----
      INTEGER S,X,Y,XX,RETC,RETU,GLCOUN,GLNKW,GLLEV,
     1        X2,GLLBEF,GET,CCOL
      LOGICAL LISTP,NLISTP
       LISTP(IDUMMY) = IDUMMY.GT.NATOM .AND. IDUMMY.LE.NFREET
      NLISTP(IDUMMY) = IDUMMY.LE.NATOM .OR.  IDUMMY.GT.NFREET
C
C--------------------------------------MAIN ENTRY
      X = S
      CALL APUSH2(IP,LMARG)
C                                      STACK OVERFLOW PREVENTION
      IF (STACK(IP).EQ.16) RETURN
      IDIV = 3
      IF (DREG(2).NE.NIL) IDIV = 5
      LEVELM = (JP-IP)/IDIV -1
      IF (LEVELP.LT.LEVELM) LEVELM = LEVELP
      JPOLD = JP
      GLLEV = 0
      CCOL = 2*MARG/3
      JPCOM = -10
      X2 = NIL
      RETU = 2
      GOTO 1000
C--------------------------------------RETURN
C--TERMINAL INTERRUPT (FROM UNKWOTE)
18    CALL TERPRI
C--FROM PRINT-S
20    JP = JPOLD
      CALL APOP2(LMARG,IP)
      RETURN
C
C--------------------------------------ENTRY LASTDEPTH(X)
500   LDEPTH = GLLEV
      RETU = 1
C--FROM UNKWOTE
510   IF (LDEPTH.EQ.LEVELM .OR. NLISTP(X)) GOTO 550
      LDEPTH = LDEPTH+1
C                                      X := LAST(X)
      DO 520 I = 1,LEVELL
         Y = CDR(X)
         IF (Y.EQ.NIL) GOTO 530
         X = Y
         IF (NLISTP(Y)) GOTO 510
520      CONTINUE
      GOTO 550
C                                      X := UNKWOTE(CAR(X))
530   X = CAR(X)
      GOTO 1000
C                                      RETURN(LDEPTH)
550   IRET = LDEPTH-GLLEV
      GOTO 5020
C
C--------------------------------------ENTRY UNKWOTE(X)
1000  IF(IBREAK)GOTO 18
      GLCOUN = 0
      IF (DREG(3).EQ.NIL) GOTO 1010
1005  IF (NLISTP(X)) GOTO 1010
      Y = CDR(X)
      IF (CAR(X).NE.QUOTE .OR. NLISTP(Y)) GOTO 1010
      IF (CDR(Y).NE.NIL) GOTO 1010
      GLCOUN = GLCOUN+1
      X = CAR(Y)
      GOTO 1005
1010  IF (RETU.EQ.2 .OR. RETU.EQ.4) GLNKW = GLCOUN
      GOTO (510,2000,1504,5105), RETU
C
C--------------------------------------ENTRY NCHARS(X)
1500  JPSAV = JP
      RETU = 3
C                                      COUNT THE QUOTES.
      GOTO 1000
C--FROM UNKWOTE
1504  IRET = IRET+GLCOUN
C                                      GONE PAST RIGHT MARGIN ?
      IF (IRET.GT.MARG) GOTO 1580
C                                      A LITATOM ?
      IF (X.GT.NATOM) GOTO 1520
      IF (CAR(X).EQ.ARRAY) GOTO 1530
      IRET = IRET+(PNP(X+1)-PNP(X))+1
      GOTO 1590
C                                      A NUMBER ?
1520  IF (X.GT.NFREET) GOTO 1530
C                                      DEEP ENOUGH ?
      IF (GLLEV+(JPSAV-JP)/2 .LT. LEVELM) GOTO 1550
1530  IRET = IRET+4
      GOTO 1590
C                                      GO DOWN CAR DIRECTION
1550  JP = JP-2
      STACK(JP+1) = 0
1555  STACK(JP) = X
      X = CAR(X)
      GOTO 1000
C                                      ... AND CDR DIRECTION
1560  X = STACK(JP)
      IF (X.LT.NIL) GOTO 1585
      X = CDR(X)
C                                      SIMULATE A GRAPHIC  ---  ?
      STACK(JP+1) = STACK(JP+1) + 1
      IF (STACK(JP+1).GE.LEVELL) X = NUMADD
      IF (LISTP(X)) GOTO 1555
      STACK(JP) = -1
      GOTO 1000
C                                      BACKUP
1580  JP = JPSAV-2
1585  JP = JP+2
1590  IF (JPSAV-JP) 1580,1591,1560
C                                      EXIT
1591  IF (JPCOM) 5032,5032,3001
C
C--------------------------------------ENTRY PRINT-S(X)
C
C--FROM UNKWOTE                        DEEP ENOUGH ?
2000  IF (GLLEV.GE.LEVELM .AND. LISTP(X)) X = -1
      IF (NLISTP(X)) GOTO 2030
C                                      PRINT-L(X,X2)
2010  IF (X2.GT.NUMADD) X2 = X2-1
      IF (DREG(2).NE.NIL) CALL APUSH2(LPRBRK,LLMARG)
      CALL APUSH3(LI,X2,X)
      IF (JP.EQ.JPCOM) DREG(2) = NIL
      GOTO 5000
C--FROM PRINT-L
2020  IF (JP.EQ.JPCOM) DREG(2) = T
      CALL APOP3 (X,X2,LI)
      IF (DREG(2).NE.NIL) CALL APOP2 (LLMARG,LPRBRK)
      GLLBEF = T
      IF (JP-IDIV.NE.JPCOM) GOTO 2040
      JPCOM = -10
      IF (LMARG.EQ.10) GOTO 2500
C--FROM TERPRI2
2025  LMARG = XX
      GOTO 2040
C                                      PRINAT(X)
2030  CALL PRINAT(X,GLNKW,JPOLD)
      GLLBEF = NIL
2040  IF (GLLEV) 20,20,5120
C
C--------------------------------------ENTRY TERPRI2
2500  DO 2510 I = 1,2
2510     CALL TERPRI
      IF (JPCOM) 2025,2025,3040
C
C--------------------------------------ENTRY LINEBREAK(X)
3000  IF (LPRBRK.EQ.-1) GOTO 3030
C                                      COMMENT NEXT ?
      IF (NLISTP(X)) GOTO 3010
      XX = CAR(X)
      IF (XX.GT.NATOM) GOTO 3010
      XX = GET(XX,FNCELL)
      IF (CDR(XX).NE.QUOTE) GOTO 3010
C                                      SWITCH TO COMMENT MODE
      JPCOM = JP-IDIV
      XX = LMARG
      LMARG = CCOL
      IRET = 20-MARG
C                                      CALL NCHARS(X)
      GOTO 1500
C--FROM NCHARS
3001  X = STACK(JP)
      X = CAR(X)
      IF (IRET.LE.MARG) GOTO 3025
      LMARG = 10
      GOTO 2500
C                                      NOT COMMENT
3010  IF (LI.LT.2 .OR. LPRBRK.NE.1) GOTO 3020
      IF (LISTP(X)) GOTO 3025
C                                      PROG--LABEL
      CALL TERPRI
      PRTPOS = LMARG-5
      GOTO 3040
C                                      NOT PROG.
3020  IF (.NOT.(LISTP(X) .OR. GLLBEF.NE.NIL)) GOTO 3030
3025  IF (PRTPOS.GE.LMARG) CALL TERPRI
      PRTPOS = LMARG
      GOTO 3040
C                                      (SPACES 1)
3030  PRTPOS = PRTPOS+1
C--FROM TERPRI2                        RETURN
3040  GOTO 5110
C
C--------------------------------------ENTRY PRINT-C
3500  IF (PRTPOS.GE.MARG+1) CALL TERPRI
      PRBUFF(PRTPOS) = IC
      PRTPOS = PRTPOS+1
      GOTO (5030,5210,5010), RETC
C
C--------------------------------------ENTRY PRINT-L
C
C THE VARIABLE LPRBRK CARRIES INFORMATION ABOUT WHEN TO PERFORM
C TERPRI AND WHEN NOT.  IT IS TESTED BY LINEBREAK.  IT CONTAINS
C THE FOLLOWING INFO:
C
C <0       MEANS THAT LINEBREAK WILL NOT PERFORM ANY TERPRI-ES.
C           THIS WILL BE THE CASE IF  E I T H E R
C           1) THE EXPRESSION ALMOST CERTAINLY WILL FIT ON LINE,  O R
C           2) NO PARENTHESISES WILL BE VISIBLE INSIDE THIS
C              EXPRESSION, DUE TO THE CURRENT PRINTLEVEL.
C >0  INFO ABOUT CAR(CURRENT EXPRESSION)
C    = 0    ATOM
C    = 1    THE ATOM PROG
C    = 2    A LIST
C
5000  LI = 0
      LLMARG = LMARG
      LPRBRK = -1
C                                      PRINT ZERO OR MORE '-S
      IC = IQCHR
      RETC = 3
C--FROM PRINT-C
5010  IF (GLNKW.EQ.0) GOTO 5015
         GLNKW = GLNKW-1
         GOTO 3500
5015  IC = LPAR
      RETC = 1
      IF (X2.NE.NIL) GOTO 3500
C                                      X2=NIL, CALL LASTDEPTH
      IF (DREG(2).NE.NIL) GOTO 500
      IRET = 0
      GOTO 5025
C--FROM LASTDEPTH
5020  IF (IRET.GT.MAXPAR) IC = ILBCHR
      IF (IRET.LE.MAXPAR) IRET = 0
5025  STACK(JP+1) = IRET+NUMADD
      GOTO 3500
C--FROM PRINT-C                        WE HAVE PRINTED ( OR <
5030  IF (DREG(2).EQ.NIL) GOTO 5050
C                                      TEST IF X WILL FIT ON LINE
      IF (GLLEV+1.GE.LEVELM) GOTO 5040
      IF (DREG(7).NE.NIL) GOTO 5035
C                                      CALL NCHARS(X)
      X = STACK(JP)
      IRET = PRTPOS
      GOTO 1500
C--FROM NCHARS
5032  IF (IRET.LE.MARG) GOTO 5040
5035  X = STACK(JP)
      X = CAR(X)
      LPRBRK = 0
      IF (X.EQ.PROG) LPRBRK = 1
      IF (LISTP(X)) LPRBRK = 2
5040  LMARG = PRTPOS+1
      IF (LMARG.GT.MARG-3) LMARG = MARG-3
5050  GLLEV = GLLEV+1
C                                      THE 'BIG' LOOP
5100  X = STACK(JP)
      X = CAR(X)
      RETU = 4
      GOTO 1000
C--FROM UNKWOTE
5105  IF (LI.GT.0) GOTO 3000
C--FROM LINEBREAK                      CALL PRINT-S
5110  X2 = STACK(JP)
      STACK(JP) = CDR(X2)
      X2 = NIL
      IF (STACK(JP).EQ.NIL) X2 = STACK(JP+1)
      GOTO 2000
C--FROM PRINT-S
5120  LI = LI+1
C                                      PERHAPS MOVE LMARG FURTHER RIGHT
      IF (LI.NE.1 .OR. (LPRBRK+2)/2.NE.1) GOTO 5130
      IF (PRTPOS.LT.(MARG + ITABWG*LMARG)/(ITABWG+1)) LMARG = 1+PRTPOS
C                                      TAKE NEXT ELEMENT OF LIST
5130  X = STACK(JP)
      IF (X.EQ.NIL) GOTO 5200
      IF (LISTP(X)) GOTO 5150
C                                      ATOM IS NEXT
      IF (PRTPOS+2.GE.MARG) CALL TERPRI
      PRBUFF(PRTPOS+1) = DOT
      PRTPOS = PRTPOS+3
      GOTO 5160
C                                      LIST IS NEXT
5150  IF (LI.LT.LEVELL) GOTO 5100
      X = -2
      PRTPOS = PRTPOS+1
C                                      CALL PRINAT
5160  CALL PRINAT(X,GLNKW,JPOLD)
C                                      PRINT ) OR >
5200  X2 = STACK(JP+1) - NUMADD
      IF (X2.LT.0 .OR. X2.GT.1) GOTO 5210
      IC = RPAR
      RETC = 2
      IF (X2.EQ.1) IC = IRBCHR
      GOTO 3500
C--FROM PRINT-C
5210  GLLEV = GLLEV-1
      LMARG = LLMARG
      GOTO 2020
C
      END
      SUBROUTINE PRINAT(X,NKW,JPOLD)
        INCLUDE 'F4COM.FOR'
C-----
C
C     PRINAT WILL PRINT A LISP ATOM OR:
C
C     X = -1  ==>  THE SYMBOL  ...
C       = -2  ==>              ---
C
C     NKW IS THE NUMBER OF '-S TO PRINT
C
C     JPOLD IS A SAVED STACK POINTER, IN CASE OF ERROR
C-----
      INTEGER OLDPOS,X,NKW,GETNUM,GETCHT,GETPN
C
      LOGICAL CLEAR
      CLEAR=PRTPOS.EQ.1
      OLDPOS = PRTPOS
C ***                                   DELETED STATEMENT(S). ***
      IPL = 0
      IF (NKW.EQ.0) GOTO 150
      DO 100 I = 1,NKW
         PRBUFF(PRTPOS) = IQCHR
100      PRTPOS = PRTPOS+1
150   IF (X.GE.NIL) GOTO 200
C                                      ... OR ---
      ISI = 3
      IPL = 3
      IC = DOT
      IF (X.EQ.-2) IC = IMINUS
      GOTO 300
200   IF (X.LE.NATOM) GOTO 295
C                                      --- NUMBER ---
      IF (X.GT.BIGNUM) CALL PRIINT(X-NUMADD)
      IF (X.LE.BIGNUM) CALL PRIFLO(GTREAL(X,IRET))
      GOTO 900
C                                      --- LITERAL ---
C                                      PICK UP ITS LENGTH
295   IF (CAR(X).NE.ARRAY) GOTO 296
      PRBUFF(PRTPOS) = NOCHAR
      PRTPOS = PRTPOS+1
      CALL PRIINT(X)
      GOTO 900
296   ISI = 1+GETPN(X,MAIN,JB,IPL)
      IF (ISI.EQ.0) GOTO 9100
      IF (ISI.EQ.2 .AND. DREG(5).EQ.NIL) ISI = 1
      IF (ISI.EQ.1) GOTO 300
      PRBUFF(PRTPOS) = STRCHR
      PRTPOS = PRTPOS+1
300   IF (IPL.EQ.0) GOTO 850
         IF (PRTPOS.GT.IOBUFF-3) GOTO 910
310      IF (ISI.GT.2) GOTO 700
C                                      GET CHAR
         CALL GETCH(PNAME,IC,JB)
         JB = JB+1
         IF (DREG(5).EQ.NIL) GOTO 700
C                                      GET TYPE
         JJ = GETCHT(IC)
C                                      % MAY BE NEEDED
         GOTO (400,500), ISI
400      IF (JJ.LE.8 .OR.  JJ.EQ.23) GOTO 600
         IF (JJ.EQ.9 .AND. X.EQ.DOTAT) GOTO 600
         GOTO 700
500      IF (JJ.NE.6 .AND. JJ.NE.23) GOTO 700
600      PRBUFF(PRTPOS) = ATEND
         PRTPOS = PRTPOS+1
700      PRBUFF(PRTPOS) = IC
         PRTPOS = PRTPOS+1
         IPL = IPL-1
         GOTO 300
C                                      ATOM NOW STORED. OFLO TEST.
850   IF (ISI.NE.2) GOTO 900
      PRBUFF(PRTPOS) = STRCHR
      PRTPOS = PRTPOS+1
900   IF (PRTPOS.LE.MARG+1) GOTO 1200
C                                      YES, IT HAS OVERFLOWED.
910   NEWPOS = PRTPOS
C                                      OUTPUT ANY OLD INFO
      IF (CLEAR) GOTO 915
      CLEAR=.TRUE.
      PRTPOS=OLDPOS
      CALL TERPRI
C               CLEAR RIGHT MARGIN BY MOVING TEXT LEFT
915   L=NEWPOS-OLDPOS
      PRTPOS=(MARG+1)-L
      IF (PRTPOS.GT.LMARG) PRTPOS=LMARG
      IF (PRTPOS.LT.1) PRTPOS=1
      DO 930 J=1,L
         IF (PRTPOS.LE.MARG) GOTO 920
         CALL TERPRI
         PRTPOS=1
920      IF (PRTPOS.EQ.OLDPOS) GOTO 925
         PRBUFF(PRTPOS)=PRBUFF(OLDPOS)
         PRBUFF(OLDPOS)=SPACE
925      PRTPOS=PRTPOS+1
930      OLDPOS=OLDPOS+1
      OLDPOS=PRTPOS-L
      IF (OLDPOS.LT.1) OLDPOS=1
C                                      PERHAPS JUMP BACK TO THE LOOP
950   IF (IPL.GT.0) GOTO 310
C                                      READY. RETURN.
1200  RETURN
C                                      ERROR: INVALID SUBSTRING
9100  X = NIL
      ERRTYP = 29
      IBREAK = .TRUE.
      GOTO 295
      END
      SUBROUTINE PRIFLO(R)
        INCLUDE 'F4COM.FOR'
      IE = 0
      IF(R) 2,9,3
2     R = -R
      PRBUFF(PRTPOS) = IMINUS
      PRTPOS = PRTPOS+1
C                                      CHOOSE E OR F FORMAT
3     S = R
      IF (R.GE.1.) GOTO 45
C                                      R .LT. 1.
41    IF (-IE.GE.IPOWER .OR. S.GE.1.) GOTO 44
      IE = IE-1
      S = S*10.
      GOTO 41
44    IF (-IE.LE.3) IE = 0
      GOTO 50
C                                      R .GE. 1.
45    IF (IE.GE.IPOWER .OR. S.LT.10.) GOTO 46
      IE = IE+1
      S = S/10.
      GOTO 45
46    U = S
      DO 48 I = 1,IRESOL
         IF (U.GE.1.) LEN = I
48       U = 10.*AMOD(U,1.)
C *** CHANGED BY TR
      IF(IE.LT.IRESOL)IE=O
C                                      NORMALIZE
50    IF (IE.NE.0) R = S
      R = R*(1.+FUZZ/S)
      NUM = R
      LIMIT = PRTPOS+IRESOL+1
C OUTPUT NUMBER OF INTEGERS WHICH CAN BE HANDELED BY PRIINT
C IF 10**IRESOL GT LARGEST INTEGER PRIINT MUST BE CALLED IN LOOP
51    IF(R.LT.MAXBIG)GOTO 52
      NUM=INT(R/RMAX)
      CALL PRIINT(NUM)
      R=AMOD(R,RMAX)
      GOTO 51
52    NUM=R
      IF (NUM.NE.0) CALL PRIINT(NUM)
C ***                                   DELETED STATEMENT(S). ***
      PRBUFF(PRTPOS) = DOT
      PRTPOS = PRTPOS+1
      IPOS0=PRTPOS
6     R = 10.*AMOD(R,1.)
      IF (R.EQ.0. .OR. PRTPOS.GE.LIMIT) GOTO 7
      NUM = R
      PRBUFF(PRTPOS) = IFIG(NUM+1)
      PRTPOS = PRTPOS+1
      IF (NUM.GT.0) IPOS0 = PRTPOS
      GOTO 6
C                                      STRIP ZEROS
7     IF (IPOS0.EQ.PRTPOS) GOTO 8
      PRTPOS = PRTPOS-1
      PRBUFF(PRTPOS) = SPACE
      GOTO 7
C                                      EXP. PART
8     IF (IE.EQ.0) RETURN
      PRBUFF(PRTPOS) = ECHAR
      PRTPOS = PRTPOS+1
9     CALL PRIINT(IE)
      RETURN
      END
      SUBROUTINE PRIINT(INUM)
        INCLUDE 'F4COM.FOR'
C                                      PRINT (-)INTEGER
      NUM = INUM
100   IF (NUM.GE.0) GOTO 101
      PRBUFF(PRTPOS) = IMINUS
      PRTPOS = PRTPOS+1
      NUM = -NUM
101   ISI = PRTPOS+19
C                                      THIS LOOP OUTPUTS DIGITS
      DO 270 I = 1,19
         JJ = MOD(NUM,10)+1
         PRBUFF(ISI) = IFIG(JJ)
         NUM = NUM/10
         IF (NUM.EQ.0) GOTO 280
270      ISI = ISI-1
280   K = PRTPOS+19
C                                      THIS LOOP POSITIONS THEM
      DO 290 I = ISI,K
         PRBUFF(PRTPOS) = PRBUFF(I)
         PRBUFF(I) = SPACE
290      PRTPOS = PRTPOS+1
      RETURN
      END
      SUBROUTINE TERPRI
        INCLUDE 'F4COM.FOR'
C             FIRST TEST IF CALLED FROM PRIN1
C             IF NOT, DO NOT WRITE ON LUNUT
      INTEGER GARB
      K = PRTPOS-1
      IF (IFLG2.EQ.T) GOTO 10
      IF(IFLG1 .NE. NIL) GOTO 20
      IF (K.LT.1) K=1
      CALL WRA1(LUNUT,PRBUFF,1,K)
      DO 1 I=1,K
1     PRBUFF(I)=SPACE
3     PRTPOS=LMARG
      RETURN
C                                      CALLED BY CONCAT
10    IF (NIL.EQ.MATOM(-K)) GOTO 22
      NATOMP = NATOMP-1
11    DO 12 I = 1,K
         CALL PUTCH(PNAME,PRBUFF(I),JBP)
         PRBUFF(I) = SPACE
12       JBP = JBP+1
      PNP(NATOMP+1) = JBP
      PRTPOS = LMARG
      RETURN
C                                      CALLED BY NCHARS
20    IFLG1 = IFLG1+K
22    DO 24 I = 1,K
24       PRBUFF(I) = SPACE
      PRTPOS=1
      RETURN
      END
      SUBROUTINE IPRINT(I)
      CALL PRIN1(I)
      CALL TERPRI
      RETURN
      END
      FUNCTION IREAD(N)
        INCLUDE 'F4COM.FOR'
      INTEGER BRSTK,RATOM,CONS,X,Y,S1,SN
      EQUIVALENCE (X,TEMP1),(S1,TEMP2),(BRSTK,TEMP3)
C-----
C     IMPORTANT VARIABLES:
C
C     X         ATOM RETURNED BY  RATOM.
C               ALSO USED AS RETURN VALUE FROM RECURSIVE CALLS
C     IT        TYPE OF ATOM RETURNED BY  RATOM
C     S1        BEGINNING OF SUBLIST (LOCAL TO  LIST-L)
C     SN        LAST ELEMENT OF SUBLIST  S1  (LOCAL TO LIST-L)
C-----
C                                      INITIALIZE
      BRLEV = NUMADD
      BRSTK = NIL
      BRFLG = NIL
C                                      STACK RETURN ADDRESS
      CALL FPUSH(1)
      GOTO 190
C--R1
C                                      NORMAL RETURN FROM IREAD
100   IREAD = X
      RETURN
C
C                                      RECURSIVE RETURN
C
900   I = STACK(IP)
      IF (I.GT.4) GOTO 9000
      IP = IP-1
      GOTO (100,220,310,340),I
C
C--------------------------------------RECURSIVE PROCEDURE READ-S
C
190   IT = RATOM(X,1)
CDEBUG      WRITE(LUNUTS,191) IT
CDEBUG191   FORMAT(' IT AT 190 = ',I4)
200   GOTO (900,290,230,210,900),IT
C            A   (   )   '   .
210   CALL FPUSH(2)
      BRLEV = BRLEV + 1
      GOTO 190
C--R2
220   BRLEV = BRLEV - 1
      X = CONS(QUOTE,CONS(X,NIL))
      GOTO 900
C                                      ') OR '> ENCOUNTERED
230   BRLEV = BRLEV + 1
      GOTO 900
C
C--------------------------------------RECURSIVE PROCEDURE READ-L
C
290   S1 = NIL
      SN = NIL
300   IT = RATOM(X,1)
C                                      E-O-LIST
      IF (IT.EQ.3) GOTO 390
C                                      APPLY READ-S TO X
C                                      AND SET X = CONS(RESULT,NIL)
      IF (IT.EQ.1 .OR. IT.EQ.5) GOTO 320
      CALL FPUSH(3)
      CALL APUSH2(S1,SN)
      GOTO 200
C--R3
310   CALL APOP2(SN,S1)
320   X = CONS(X,NIL)
C                                      JUST INITIALIZE IF AT
C                                      BEGINNING OF LIST
      IF (S1.EQ.NIL) GOTO 330
C                                      TAKE CARE OF TRUE DOT
      IF (IT.NE.5 .OR. CAR(X).NE.DOTAT) GOTO 360
      CALL FPUSH(4)
      CALL APUSH2(S1,SN)
330   S1 = X
      SN = X
      GOTO 300
C--R4
340   CALL APOP2(SN,S1)
      Y = CDR(X)
      IF (Y.LE.NATOM .OR. Y.GT.NFREET) GOTO 350
      IF (CDR(Y).EQ.NIL) X = CAR(Y)
C*SETC*350   CALL SETCDR(SN, X)
350    CDR(SN)= X 
      GOTO 390
C                                      JUST APPEND X TO SN
C                                      AND GO ON LOOPING
C*SETC*360   CALL SETCDR(SN, X)
360    CDR(SN)= X 
      SN = X
      GOTO 300
C                                      X = RETURN(S1) FROM READ-L
390   X = S1
      GOTO 900
C--------------------------------------ERROR RETURNS
C
C  PDL OVERFLOW
9000  IREAD = NIL
      RETURN
      END
      INTEGER FUNCTION RATOM(X,IOP)
        INCLUDE 'F4COM.FOR'
      INTEGER CONS,X,BRSTK,CHTSAV
      DOUBLE PRECISION SUM(3),R,S,D
      REAL S1
      EQUIVALENCE (BRSTK,TEMP3)
C-----
C
C     IOP = 0        CALLED BY LISPF4
C           1        CALLED BY IREAD - DON'T RETURN <, >
C
C     CHR            CURRENT CHAR
C     CHT            TYPE OF CURRENT CHAR
C         = -1        EOF
C            0        EOL
C           >0        TYPE RETURNED FROM GETCHT
C     IRFLAG           FLAG FOR RECOGNIZING NUMBERS
C     ISIGN           FLAG FOR RECOGNIZING SIGN OF NUMATOM
C     ISUM            COUNTER TO PICK UP VALUE OF NUMATOM
C
C     RATOM = 1      ATOM
C             2      (     (X = NIL)
C             3      )     (X = NIL)
C             4      '     (X = NIL)
C             5      .     (X = .) !!
C-----
      RATOM = 1
      X = NIL
      IRFLAG = 1
      ISIGN = 1
      IF (BRFLG.EQ.NIL) GOTO 1010
      RATOM = 3
      GOTO 2040
C                                      SKIP DELIMITERS
1000  CALL SHIFT(2)
1010  IF (CHT.LE.1) GOTO 1000
      CHTSAV = CHT
      IF (CHT.LE.5) GOTO 2000
      IF (CHT.GE.25) CHT = 10
      IF (CHT.GE.13) GOTO 4101
      I = CHT-5
      GOTO (3000,3200,5000,4010,4100,4101,4000),I
C            "    '    UBR  .    A    +    -
C
C                                      BREAK CHARACTERS
C                                      (  )  <  >
C                                      SET-UP THE RETURN VALUE
2000  RATOM = CHT
      IF (CHT.GE.4) RATOM = CHT-2
      IF (IOP.EQ.0) GOTO 5000
C                                      CALLED BY IREAD
C                                      - KEEP TRACK OF ( ) < >
      I = CHT-1
      GOTO (2020,2040,2010,2030), I
C <                                    PUSH PARENTHESIS LEVEL
2010  BRSTK = CONS(BRLEV,BRSTK)
      BRLEV = NUMADD
C (
2020  BRLEV = BRLEV+1
      CHT = 0
      GOTO 6000
C >                                    BRFLG = T  WILL PREPARE FOR
C                                      VIRTUAL )'S
2030  BRFLG = T
C )
2040  BRLEV = BRLEV-1
      CHT = 0
      IF (BRLEV-NUMADD) 2045,2050,6000
C                                      ) OR > HAS BEEN ENCOUNTERED ON
C                                        TOP LEVEL - JUST RETURN NIL
2045  RATOM = 1
      GOTO 2060
C                                      ONE SUPER-BRACKED IS MATCHED
C                                      - POP PREVIOUS PARENTHESIS LEVEL
2050  BRLEV = CAR(BRSTK)
      BRSTK = CDR(BRSTK)
2060  BRFLG = NIL
      RETURN
C "                                    START OF STRING. READ
C                                       ALL OF IT.
3000  CALL SHIFT(2)
      I1CONS = MATOM(0)
      DO 3090 I = 1,MAXINT
         K = 1
         IF (CHT.EQ.6) GOTO 3100
         IF (CHT.LE.0) K = 3
3090     CALL SHIFT(K)
C                                      WHOLE STRING READ
3100  CALL SHIFT(3)
      X = I1CONS
      RETURN
C '                                    JUST SET-UP RETURN VALUE
3200  RATOM = 4
      IF (IOP.EQ.0) GOTO 5000
      CALL SHIFT(2)
      RETURN
C -                                    MAY BE BEGINNING OF NUMBER
4000  ISIGN = -1
      GOTO 4101
C .                                    MAY BE BEGINNING OF NUMBER
4010  IRFLAG = 2
      GOTO 4101
C A
4100  IRFLAG = 9
      GOTO 4110
C                                      THIS LOOP READS UNTIL BREAK-CHAR
C                                      - IF THE ATOM CAN BE INTERPRETED
C N                                       AS A NUMBER, IT WILL.
4101  SUM(1) = 0.
      SUM(2) = 0.
      SUM(3) = 0.
      IDIGS = 0
      NEW = -13
      DIV2 = 1.
      ISIGN3 = 1
      IF (CHT.LT.13) CHT = 13
4105  SUM(IRFLAG) = 10.*SUM(IRFLAG)+FLOAT(CHT-13)
4110  CALL SHIFT(1)
      IF (CHT.LT.9) GOTO 4500
      IF (IRFLAG.GT.3) GOTO 4110
      IF (CHT.GE.13 .AND. CHT.LT.23) GOTO 4200
      IF (CHT.GE.13) CHT = CHT-12
      I = CHT-8
      GOTO (4120,4100,4140,4150,4130,4100), I
C .                                    ALLOWED IF IRFLAG = 1
4120  IF (IRFLAG.GT.1) GOTO 4100
      IRFLAG = 2
      GOTO 4110
C E                                    ALLOWED IF IRFLAG = 1 OR 2
4130  IF (IRFLAG.GT.2) GOTO 4100
      IRFLAG = 3
      GOTO 4110
C +                                    ALLOWED IF IRFLAG = 3
4140  IF (IRFLAG-3) 4100,4110,4100
C -                                    ALLOWED IF IRFLAG = 3
4150  IF (IRFLAG.NE.3) GOTO 4100
      ISIGN3 = -1
      GOTO 4110
C DIGIT
4200  IF (IRFLAG.EQ.1 .AND. SUM(1).GT.0.) IDIGS = IDIGS+1
      IF (IRFLAG.EQ.2 .AND. SUM(1)+SUM(2).EQ.0.) IDIGS = IDIGS-1
      IF (IRFLAG.EQ.2) DIV2 = DIV2*10.
      GOTO 4105
C                                      END OF NUMBER
4500  IF (IRFLAG.GT.3) GOTO 5100
      IF (CHTSAV.LE.12 .AND. ABUP1.EQ.1) GOTO 5100
C                                      REAL NUMBER
      R = SUM(1)+SUM(2)/DIV2
      X = NUMADD
      IF (R.EQ.0.) GOTO 6000
      IE = ISIGN3*INT(SUM(3))
      IF (IE.GT. IPOWER-IDIGS) IE =  IPOWER-IDIGS
      IF (IE.LT.-IPOWER-IDIGS) IE = -IPOWER-IDIGS
4515  IF (IE) 4520,4590,4530
4520  IE = IE+1
      R = R/10.
      GOTO 4515
4530  IE = IE-1
      R = R*10.
      GOTO 4515
C                                      SMALL NUMBER
4590  S = R
      IF (ISIGN.LT.0) S = -R
      D=ISMALL
      IF (IRFLAG.GT.1      .OR. R.GT.D) GOTO 4591
      X = INT(S)+NUMADD
      GOTO 6000
4591  S1=S
      X = MKREAL(S1)
      GOTO 6000
C                                      USER BREAK CHARACTER
5000  CALL SHIFT(1)
C                                      RETURN STRING OR LITATOM
5100  X = MATOM(ABUP1)
C                                      SIGNAL IF IT IS A  .  WITHOUT  %
      IF (X.EQ.DOTAT .AND. CHTSAV.EQ.9) RATOM = 5
6000  ABUP1 = 0
      RETURN
      END
      SUBROUTINE SHIFT(I)
        INCLUDE 'F4COM.FOR'
      INTEGER GETCHT
C-----
C     I = 1       STORE PREVIOUS CHAR
C         2       DON'T STORE IT
C         3       STORE IN PNAME
C
C     IFLG2 = T   READ FROM PRBUFF   (CALLED BY PACK)
C             NIL READ FROM LUNIN    (CALLED BY RATOM)
C-----
C
1000  GOTO (1001,1010,1003), I
C                                      STORE PREVIOUS CHAR
1001  ABUP1 = ABUP1+1
         ABUFF(ABUP1) = CHR
1010  IF (IFLG2.NE.NIL) GOTO 2000
      GOTO 1100
C                                      STORE IN PNAME
1003  IF (NIL.EQ.MATOM(-ABUP1)) GOTO 1100
      NATOMP = NATOMP-1
      PNP(NATOMP+1) = PNP(NATOMP+2)
C                                      NOW CALLED BY RATOM
1100  IF (RDPOS.GT.MARGR) GOTO 1200
      CHR = RDBUFF(RDPOS)
      RDPOS = RDPOS+1
C                                      WAS PREVIOUS CHAR  %
C                                       THEN WE MUST HAVE COME
C                                        FROM DOWN BELOW.
      IF (CHT.NE.23) GOTO 1150
         CHT = 10
         J = GETCHT(CHR)
         IF (J.GE.11 .AND. J.LT.23) CHT=J
         RETURN
1150  CHT = GETCHT(CHR)
C                                      DON'T RETURN IF  %  IS READ
      IF (CHT.EQ.23) GOTO 1100
C                                      INPUT BREAK ?
      IF (CHT.NE.24) GOTO 1160
         ERRTYP = 27
         IBREAK = .TRUE.
         CHT = 10
1160  RETURN
C                                      NEW LINE
C                                      ** THIS IS THE ONLY CALL TO RDA1
1200  CALL RDA1(LUNIN,RDBUFF,1,MARGR,IEOF)
CDEBUG      WRITE(LUNUTS,1201)(RDBUFF(IIII),IIII=1,6)
CDEBUG1201  FORMAT(' RDBUFF=',6A5)
      IF (IEOF.EQ.2) GOTO 1300
      RDPOS = LMARGR
      CHT = 0
      RETURN
C                                      E-O-FILE
C*** CHANGED BY TR
1300  IF (LUNIN.NE.LUNINS) GOTO 1350
C        CALL MESS(32)
C        CALL LSPEX
C                                      ... BUT NOT ON LUNINS
C                                       SWITCH BACK TO LUNINS
1350  IF(LUNIN.NE.LUNINS) CALL REW(LUNIN)
      LUNIN = LUNINS
      CHT = -1
      RETURN
C----------------------------------------------------------
C                                      NOW CALLED BY PACK
C
C                                      HERE WE MAY RETURN IN CHT:
C                                       SEP. + - . DIGIT LETTER
C
C                                      ARG2 = MAX PRTPOS
C
2000  IF (PRTPOS.LE.ARG2) GOTO 2010
         CHT = 0
         RETURN
2010  CHR = PRBUFF(PRTPOS)
      PRTPOS = PRTPOS+1
      CHT = 10
      J = GETCHT(CHR)
      IF (J.GE.9 .AND. J.LT.23 .OR. J.GE.25) CHT = J
      RETURN
      END
      INTEGER FUNCTION GARB(GBCTYP)
        INCLUDE 'F4COM.FOR'
      INTEGER ARGS(10),S,RET,GBCTYP
      LOGICAL SPECAT
      INTEGER*2 JPNAME(1),JDUMMY
      INTEGER INDS(3),LENS(3),IPNAME(1),ARRLST
      EQUIVALENCE (ARG,ARGS(1))
      EQUIVALENCE (PNAME(1),IPNAME(1),JPNAME(1))
      SPECAT(JDUMMY) = JDUMMY.EQ.STRING .OR. JDUMMY.EQ.SUBSTR
     *            .OR. JDUMMY.EQ.ARRAY
C               GARB(GBCTYP) PERFORM GARBAGE COLLECTION DEPENDING ON GBC
C       GBCTYP = 0      NORMAL GBC, LIST CELLS ONLY (CALLED FROM CONS)
C                1      LIST COMPACTING (CALLED FROM ROLLOUT)
C                2      BIG NUMBERS COMPACTING (CALLED FROM MKNUM)
C                3      BIG NUMBERS AND ATOMS  (CALLED FROM MKATOM)
C
C STEP 1: MARK ACTIVE CELLS AND ATOMS BY NEGATIVE CDR.
C         IF FLOATING NUMBER GBC, MARK IN PNP.
C         IF GBCTYP < 1 GO TO STEP 2.
C STEP 3: LIST COMPACTING (GBCTYP = 1,2,3)
C         MOVE ACTIVE CAR,CDR TO TOP OF FREE STORAGE AND RESET CDR.
C         LEAVE NEW ADRESS IN CDR OF MOVED CELL.
C         IF GBCTYP < 2 GO TO STEP 2.
C STEP 5: FLOATING NUMBER GBC AND COMPACTING (GBCTYP = 2,3)
C         MOVE ACTIVE NUMBERS (MARKED IN PNP) TO TOP OF PNAME.
C         LEAVE NEW ADRESS IN OLD (LOWER) PNAME
C         RESET PNP
C         IF GBCTYP < 3 GO TO STEP 2.
C STEP 4: ATOM GBC AND COMPACTING (GBCTYP = 3)
C         MOVE ACTIVE ATOMS TO LOWER ATOM AREA (LOWER CAR,CDR)
C         LEAVE NEW ADRESS IN (NEGATIVE) HTAB AND RESET CDR.
C STEP 2: RESET CDR OF MARKED ATOMS.
C         IF GBCTYP < 1 GO TO STEP 7.
C STEP 6: RESTORE MOVED POINTERS (GBCTYP = 1,2,3)
C         CHECK ALL LIST POINTERS AND CHANGE TO
C         NEW VALUE IF MOVED.
C STEP 7: CLEAR MEMORY
C         MAKE FREE LIST
C         GBCTYP = 3: REHASH ALL SAVED ATOMS
C         RETURN
C
C STEP 1:
C
C             TRACE FROM ARG,ARG2,ARG3,FORM,ALIST,TEMP1,TEMP2,TEMP3,
C                        I1CONS,I2CONS; A-STACK; THE ATOMS.
C             ARG - I2CONS = ARGS(1) - ARGS(NARGS)
      ARRLST = NIL
      INREAL = BYTES/JBYTES
      NJP=JP
      ISUM=0
      ISPARE = NIL
C THE STACK
      I=1
177   S=JACK(I)
      IF(S.LE.0)GOTO 179
      RET=6
      GOTO 30
C R-6
178   S=JILL(I) 
      RET=7
      GOTO 30
C R-7
179   I=I+1
      IF(I.LE.TOPS)GOTO 177
C ARG-I2CONS
      RET=1
      I = 1
91    S=ARGS(I)
      GOTO 30
1     I = I+1
      IF (I.LE.NARGS) GOTO 91
C A-STACK
13    IF (JP.GT.NSTACK) GOTO 16
14    RET=2
      I = JP
92    S=STACK(I)
      GOTO 30
3     I = I+1
      IF (I.LE.NSTACK) GOTO 92
C ATOMS
16    I = 1
93    RET=3
      IF (SPECAT(CAR(I)) .OR. CDR(I).LT.0) GOTO 5
      S=CAR(I)
      GOTO 30
4     S=CDR(I)
      RET=4
      GOTO 30
5     I = I+1
      IF (I.LE.NATOMP) GOTO 93
C ARRAYS
      RET = 5
6     IF (ARRLST.LE.NIL) GOTO 99
      S = ARRLST
      ARRLST = -CDR(S)
C*SETC*      CALL SETCDR(S, -NIL)
       CDR(S)= -NIL 
      CALL ARRUTL(S,3,1,IND1,LEN)
      IND2 = IND1+LEN
7     IF (IND1.EQ.IND2) GOTO 6
      S = JPNAME(IND1)
      IND1 = IND1+1
      GOTO 30
99    IF (GBCTYP) 200,200,300
C             MARKL
C             RECURSIVE ROUTINE FOR MARKING LISTS
C             MARKL MAY CALL SUBROUTINE MARKL (NON-RECURSIVE ROUTINE)
C
C             RETURNPOINTS FOR MARKL
20    GOTO (1,3,4,5,7,178,179), RET
C                                      MARK WHAT  S  POINTS AT
30    IF (S.LE.T) GOTO 50
      IF (S.GT.NFREET) GOTO 45
      ICDR = CDR(S)
      IF (ICDR.LT.0) GOTO 50
C                                      AN ARRAY?
      IF (CAR(S).NE.ARRAY .OR. S.GT.NATOM) GOTO 32
C*SETC*      CALL SETCDR(S, -ARRLST)
       CDR(S)= -ARRLST 
      ARRLST = S
      GOTO 50
32    IF (IP.LT.JP-1) GOTO 35
C                                      RECURSION IN MARKL TOO DEEP
C                                      CALL SUBROUTINE MARKL
      IF (ISUM.EQ.1 .OR. DREG(1).EQ.NIL) GOTO 31
      ISUM = 1
      CALL MESS(24)
31    CALL MARKL(S,GBCTYP,ARRLST)
      GOTO 50
C                                      STACK SPACE LEFT. START MARKING
C*SETC*35    CALL SETCDR(S, -ICDR)
35     CDR(S)= -ICDR 
      JP = JP-1
      STACK(JP) = ICDR
C                                      MARK CAR
      S = CAR(S)
      GOTO 30
C                                      MARK A NUMBER
45    IF (S.GT.BIGNUM .OR. GBCTYP.LT.2) GOTO 50
      IS = S-NFREET
      IF (PNP(IS).GT.0) PNP(IS) = -PNP(IS)
C                                      RECURSIVE RETURN
50    IF (JP.EQ.NJP) GOTO 20
      S = STACK(JP)
C                                      MARK CDR
      JP = JP+1
      GOTO 30
C
C STEP 3: LIST COMPACTING ROUTINE
C
300   IBOT=NFREEB
      ITOP=NFREET
C             STEP ONE. MOVE ACTIVE CELLS TO THE TOP OF FS
301   IF (CDR(ITOP).GE.0) GOTO 315
C*SETC*      CALL SETCDR(ITOP, -CDR(ITOP))
       CDR(ITOP)= -CDR(ITOP )
306   ITOP=ITOP-1
      IF(IBOT-ITOP) 301, 328, 328
315   IF (CDR(IBOT).LT.0) GOTO 325
320   IBOT=IBOT+1
      IF(IBOT-ITOP) 315, 330, 330
C*SETC*325   CALL SETCAR(ITOP,CAR(IBOT))
325    CAR(ITOP)=CAR(IBOT )
C*SETC*      CALL SETCDR(ITOP,-CDR(IBOT))
       CDR(ITOP)=-CDR(IBOT )
C*SETC*      CALL SETCDR(IBOT,ITOP)
       CDR(IBOT)=ITOP 
      IBOT=IBOT+1
      GO TO 306
328   IF (CDR(ITOP).GE.0) GOTO 330
C*SETC*329   CALL SETCDR(ITOP,-CDR(ITOP))
329    CDR(ITOP)=-CDR(ITOP )
      ITOP=ITOP-1
330   NFREEP=ITOP
      GOTO (200,500,500), GBCTYP
C
C STEP 4: ATOM COMPACTING ROUTINE
C
C       MOVE UNUSED ATOMS. UNUSED IF:
C     CDR.GT.0 .AND. CASE(CAR) OF
C        (SPECIAL): T;  UNBOUND: CDR.EQ.NIL;  NIL;
C
C       FIRST CLEAR HTAB. HTAB IS USED FOR HOLDING MOVED POINTERS
400   NATOMO = NATOMP
      DO 420 I=1,NHTAB
420   HTAB(I)=0
      N=T
401   NATOMP = N+1
      JBP = PNP(NATOMP)
C                                      FIND ATOM TO MOVE
402   N=N+1
      IF(N .GT. NATOMO) GOTO 405
      IF(CDR(N) .LT. 0) GOTO 403
      IF (SPECAT(CAR(N))) GOTO 402
      IF (CAR(N).EQ.UNBOUN .AND. CDR(N).EQ.NIL) GOTO 402
403   IF (N.EQ.NATOMP) GOTO 401
C       MOVE ATOM(N) TO ATOM(NATOMP) AND MARK NEW ADRESS IN -HTAB(N)
      HTAB(N) = -NATOMP
C*SETC*      CALL SETCAR(NATOMP,CAR(N))
       CAR(NATOMP)=CAR(N )
C*SETC*      CALL SETCDR(NATOMP,CDR(N))
       CDR(NATOMP)=CDR(N )
C       MOVE PNAME(N) TO PNAME(NATOMP)
C       PNAME(NATOMP) STARTS IN (1,JBP), I.E. CURRENT PNAME-POINTERS.
      JB = PNP(N)
      IPL = PNP(N+1)-JB
      IF (IPL.EQ.0) GOTO 411
      IF (JB.NE.JBP) GOTO 4030
      JBP = JBP+IPL
      GOTO 411
4030  IF (CAR(N).NE.ARRAY) GOTO 409
      DO 4031 IREG = 1,3
4031     CALL ARRUTL(N,3,IREG,INDS(IREG),LENS(IREG))
      DO 4032 IREG = 1,3
4032     CALL ARRUTL(NATOMP,4,IREG,INDS(IREG),LENS(IREG))
      GOTO 419
409   DO 410 I = 1,IPL
      CALL GETCH(PNAME,ICH,JB)
      CALL PUTCH(PNAME,ICH,JBP)
      JB=JB+1
410   JBP=JBP+1
411   PNP(NATOMP+1) = JBP
C       END OF MOVING PNAME
419   NATOMP = NATOMP+1
      GOTO 402
C       ALL ACTIVE ATOMS MOVED TO (1,NATOMP)
405   NATOMP=NATOMP-1
      GOTO 200
C       CONTINUE WITH STEP 5
C
C STEP 5: BIG NUMBERS COMPACTING
C
C       ALL ACTIVE BIG NUMBERS ARE MARKED NEGATIVE IN PNP.
C       OFFSETS FROM/TO INDEX IN CAR,INDEX IN PNP, INDEX IN PNAME ARE:
C       S -- I=S-NFREET --PNP(I) --J=I+DPNP -- PNAME(J)
C       S -- J=S+DPANME -- PNAME(J)
500   IBOT=1
      ITOP=NATOM
501   IF(PNP(ITOP) .GE. 0) GOTO 503
      PNP(ITOP)=-PNP(ITOP)
502   ITOP=ITOP-1
      IF(IBOT .GE. ITOP) GOTO 505
      GOTO 501
503   IF(PNP(IBOT) .LT. 0) GOTO 504
      IBOT=IBOT+1
      IF(IBOT .GE. ITOP) GOTO 506
      GOTO 503
504   I=ITOP+DPNP
      J=IBOT+DPNP
      PNAME(I)=PNAME(J)
      J = J*INREAL
      JPNAME(J) = ITOP+NFREET
      PNP(IBOT)=-PNP(IBOT)
      IBOT=IBOT+1
      GOTO 502
505   IF(PNP(ITOP) .GE. 0) GOTO 506
      PNP(ITOP)=-PNP(ITOP)
      ITOP=ITOP-1
506   NUMBP=ITOP+DPNP+1
      IF (GBCTYP.EQ.3) GOTO 400
C       NOW ALL ACTIVE NUMBERS ARE MOVED TO (PNAME(NUMBP), PNAME(NPNAME)
C
C STEP 2: RESTORE CDR OF ATOMS
C
200   DO 210 I = NIL,NATOMP
C*SETC*       IF (CDR(I).LT.0) CALL SETCDR(I, -CDR(I))
         IF (CDR(I).LT.0)  CDR(I)= -CDR(I )
210      CONTINUE
      IF (GBCTYP.LT.1) GOTO 700
C
C STEP 6: RESTORE MOVED POINTERS (GBCTYP 1,2,3)
C
C       CHECK ALL LIST POINTERS AND CHANGE VALUE IF MOVED.
600   NUMOVE=NUMBP-DPNAME
C THE STACK
C THE STACK
      I=1
560   S=JACK(I)
      IF(S.LE.0)GOTO 581
      IRET=6
      GOTO 650
C R-6
570   JACK(I)=S
      S=JILL(I) 
      IRET=7
      GOTO 650
C R-7
580   JILL(I)=S
581   I=I+1
      IF(I.LE.TOPS)GOTO 560
C ARG - I2CONS
      IRET = 1
      I = 1
601   IF (I.GT.NARGS) GOTO 610
      S = ARGS(I)
      GOTO 650
C<--
602   ARGS(I) = S
      I = I+1
      GOTO 601
C ASTACK
610   IRET = 2
      I = JP
611   IF (I.GT.NSTACK) GOTO 620
      S = STACK(I)
      GOTO 650
C<--
612   STACK(I) = S
      I = I+1
      GOTO 611
C ATOMS,LISTS,ARRAYS
620   I = NIL
621   IF (I.GT.NFREET) GOTO 710
      IF (I.EQ.NATOMP+1) I = NFREEP+1
      S = CAR(I)
      IRET = 3
      GOTO 650
C<--
C*SETC*622   CALL SETCAR(I, S)
622    CAR(I)= S 
      IF (S.NE.ARRAY .OR. I.GT.NATOM) GOTO 625
      CALL ARRUTL(I,3,1,IND1,LEN)
      IRET = 5
623   IF (LEN.LT.1) GOTO 625
      S = JPNAME(IND1)
      GOTO 650
C<--
624   JPNAME(IND1) = S
      IND1 = IND1+1
      LEN = LEN-1
      GOTO 623
625   S = CDR(I)
      IRET = 4
      GOTO 650
C<--
C*SETC*626   CALL SETCDR(I, S)
626    CDR(I)= S 
629   I = I+1
      GOTO 621
C
C CHANGE VALUE OF  S  IF NECESSARY
C
650   GOTO (656,654,652), GBCTYP
C A-GBC
652   IF (S.GT.NATOM) GOTO 654
      IF (HTAB(S).LT.0) S = -HTAB(S)
      GOTO 660
C N-GBC
654   IF (S.LE.NFREET) GOTO 656
      IF (S.GE.NUMOVE) GOTO 660
      ICAR = INREAL * (DPNAME+S)
      S = JPNAME(ICAR)
      GOTO 660
C C-GBC
656   IF (S.GE.NFREEB .AND. S.LE.NFREEP) S = CDR(S)
660   GOTO (602,612,622,626,624,570,580), IRET
C
C STEP 7: CLEAR MEMORY
C
C       NORMAL GBC. MAKE FREE LIST AND RETURN
700   NFREEP=NIL
      ISUM=0
      DO 702 I=NFREEB,NFREET
      IF(CDR(I) .GT. 0) GOTO 701
C*SETC*      CALL SETCDR(I,-CDR(I))
       CDR(I)=-CDR(I )
      GOTO 702
C*SETC*701   CALL SETCDR(I,NFREEP)
701    CDR(I)=NFREEP 
      NFREEP=I
      ISUM=ISUM+1
702   CONTINUE
      GARBS = GARBS+1
      MESSNR = 35
      GOTO 800
C       COMPACTING GARB. MAKE FREE LIST
710   MAX=NFREEP
      NFREEP=NIL
      DO 711 I=NFREEB,MAX
C*SETC*      CALL SETCDR(I,NFREEP)
       CDR(I)=NFREEP 
711   NFREEP=I
      GOTO (712,720,730), GBCTYP
C       CELL COMPACTING GARB
712   ISUM = NFREEP-NFREEB+1
      CGARBS=CGARBS+1
      MESSNR=3
      GOTO 800
C       NUMBER COMPACTING GARB.
720   ISUM = NUMBP-DPNP-2
      J = NUMBP-(JBP-2)/BYTES-3
      IF (J.LT.ISUM) ISUM = J
      NGARBS = NGARBS+1
      MESSNR=19
      GOTO 800
C       ATOM COMPACTING GARB
730   AGARBS=AGARBS+1
      ISUM=NATOM-NATOMP
      CALL REHASH
      MESSNR=38
C
C       EPILOGUE OF GARB. PRINT MESS IF MESSFLAG ON.
800   IF (DREG(1).EQ.NIL .OR. IFLG2.NE.NIL) GOTO 801
      CALL TERPRI
      CALL MESS(MESSNR)
      I = LUNUT
      LUNUT = LUNUTS
      PRTPOS = 12
      CALL PRIINT(ISUM)
      CALL TERPRI
      LUNUT = I
801   IF (ISUM.GT.15 .OR. GBCTYP.GE.1) GOTO 802

8011  CALL MESS(36)
C ----- !!!! -----
      CALL LISPF4(2)
C
C NOTE!  WE ARE NOT INTERESTED OF A RECURSIVE CALL TO LISPF4,
C        BUT JUST TO PERFORM A QUICK JUMP TO THE RESET ADDRESS.
C        IF YOUR RUNTIME SYSTEM COMPLAINS CHANGE THE PREVIOUS
C        CALL TO:
C     CALL LSPEX
C
802   GARB=ISUM
      RETURN
      END
      SUBROUTINE MARKL(IS,GBCTYP,ARRLST)
        INCLUDE 'F4COM.FOR'
C
C             A NON-RECURSIVE LIST TRAVELING ROUTINE WHICH USES THE
C             ALGORITHM DESCRIBED IN CACM AUG 67 (NR 8)
C
      INTEGER S,GBCTYP,ARRLST
C             AT ENTRY IS POINTS TO AN UNMARKED LIST-CELL
      I=NIL
      S=IS
C
C             FORWARD SCAN
C
1     ICDR=CDR(S)
      IF (CAR(S).NE.ARRAY .OR. S.GT.NATOM) GOTO 11
C*SETC*      CALL SETCDR(S, -ARRLST)
       CDR(S)= -ARRLST 
      ARRLST = S
      ICDR = S
      GOTO 2
11    IF (ICDR.GT.NFREET) GOTO 1024
12    IF (CDR(ICDR).LT.0) GOTO 24
C*SETC*13    CALL SETCDR(S,-I)
13     CDR(S)=-I 
      I=S
      S=ICDR
      GOTO 1
C
C             REVERSE SCAN
C
2     IF (I.EQ.NIL) GOTO 50
21    S=I
      IF (CAR(S).GE.0) GOTO 23
C             CELL MARKED AS BRANCH-POINT
22    I=-CAR(S)
C*SETC*      CALL SETCAR(S,ICDR)
       CAR(S)=ICDR 
      ICDR=S
      GOTO 2
C             NOT A BRANCH-POINT
23    I=-CDR(S)
C*SETC*24    CALL SETCDR(S,-ICDR)
24     CDR(S)=-ICDR 
      ICDR=S
      ICAR = CAR(S)
25    IF (ICAR.GT.NFREET) GOTO 1002
26    IF (CDR(ICAR).LT.0) GOTO 2
C             CAR(S) POINTS TO A SUBLIST
27    S=ICAR
C*SETC*      CALL SETCAR(ICDR,-I)
       CAR(ICDR)=-I 
      I=ICDR
      GOTO 1
C       DIFFERENT ENTRIES FOR NUMBERS
1024  IF(GBCTYP .LT. 2) GOTO 24
      IF(ICDR .GT. BIGNUM) GOTO 24
      IS=ICDR-NFREET
      IF(PNP(IS) .GT. 0) PNP(IS)=-PNP(IS)
      GOTO 24
1002  IF(GBCTYP .LT. 2) GOTO 2
      IF(ICAR .GT. BIGNUM) GOTO 2
      IS=ICAR-NFREET
      IF(PNP(IS) .GT. 0) PNP(IS)=-PNP(IS)
      GOTO 2
50    RETURN
      END
      SUBROUTINE REHASH
        INCLUDE 'F4COM.FOR'
      INTEGER HADR
      INTEGER*2 JDUMMY
      LOGICAL SPECAT
      SPECAT(JDUMMY) = JDUMMY.EQ.STRING. OR. JDUMMY.EQ.SUBSTR .OR.
     *  JDUMMY.EQ.ARRAY
C       USED TO GET A NEW ENTRY IN HTAB FOR AN EXISTING ATOM N.
C       CALLED BY ATOM GBC AND ROLLIN.
      DO 1 N=1,NHTAB
1     HTAB(N)=UNUSED
      DO 100 N=1,NATOMP
      IF (SPECAT(CAR(N))) GOTO 100
      JB = PNP(N)
      CALL GETCH(PNAME,ICH1,JB)
      L=PNP(N+1)-PNP(N)
20    CALL GETCH(PNAME,ICH2,JB+L/2)
      CALL GETCH(PNAME,ICH3,JB+L-1)
      HADR=IHADR(ICH1,ICH2,ICH3,NHTAB)
50    DO 51 I=1,NHTAB
      IF(HTAB(HADR) .EQ. UNUSED) GOTO 52
      HADR=HADR+1
      IF(HADR .LE. NHTAB) GOTO 51
      HADR=1
51    CONTINUE
52    HTAB(HADR)=N
100   CONTINUE
      RETURN
      END
      FUNCTION IHADR(ICH1,ICH2,ICH3,NHTAB)
C--
C-- THIS FUNCTION MAY NEED TO BE REWRITTEN FOR EFFICIENT
C-- HASHING ON SOME COMPUTERS (E.G. VAX-11)
C--
      IHADR=MOD(IABS(ICH1/7+ICH2/3+ICH3/5),NHTAB)+1
      RETURN
      END
      FUNCTION MATOM(K)
        INCLUDE 'F4COM.FOR'
        INTEGER GARB,HADR
C
C     K>0:  CREATE A LITERAL ATOM OF THE K BYTES IN ABUFF.
C     K<=0: CREATE A STRING OF LENGTH -K.  MOVE ABUP1 BYTES TO IT.
C
C     POINTERS USED: JBP (BYTE POINTER IN PNAME), IS UPDATED.
C                    NATOMP (ATOM POINTER), INCREASED BY 1.
C                    ABUP1 (POINTER IN ABUFF), IS RESET.
C                    NUMBP (BIGNUM POINTER IN PNAME).
C
C       FIRST CALCULATE HASH ADRESS.
      L = K
      IF(L .GT. 0) GOTO 100
C               MATOM IS TO MAKE A STRING
      L=-L
      HADR=0
      GOTO 30
C          MATOM IS TO MAKE A LITATOM
100   ABUP1 = L
      IF(DREG(4).EQ.T) CALL UPCASE(ABUFF,L)
      HADR=IHADR(ABUFF(1),ABUFF(1+L/2),ABUFF(L),NHTAB)
C       HASH ADRESS = HADR
C       LENGTH OF ATOM = L
C       SEARCH FOR EXISTING ATOM OR NEW ENTRY.
5       DO 20 I=1,NATOM
        IMATOM=HTAB(HADR)
        IF(IMATOM .EQ. UNUSED) GOTO 30
        JB = PNP(IMATOM)
        IPL = PNP(IMATOM+1)-JB
        IF(L .NE. IPL) GOTO 16
C               EQUAL LENGTHS. TEST CHARACTERS IN IBUFF - PNAME.
        DO 15 J=1,L
        CALL GETCH(PNAME,ICH1,JB)
        IF(ICH1 .NE. ABUFF(J)) GO TO 16
15      JB=JB+1
C               OLD ATOM FOUND. RETURN(IMATOM)
        GOTO 60
C               ATOM NOT FOUND, TRY NEXT.
16      HADR=HADR+1
        IF(HADR .GT. NHTAB) HADR=1
20      CONTINUE
C               NEW ATOM TO BE CREATED
30    IF (IBREAK .AND. ERRTYP.EQ.33) GOTO 56
      NALEFT = NATOM-NATOMP-1
      NBNOW  = BYTES*(NUMBP-2)-(JBP-1)
      NBLEFT = NBNOW-L
      IF (NALEFT.LT.0 .OR. NBLEFT.LT.0) GOTO 50
      IF (IBREAK) GOTO 35
      IF (NALEFT.EQ.9 .OR. NBNOW.GE.50.AND.NBLEFT.LT.50) GOTO 50
35    NATOMP = NATOMP+1
      IMATOM = NATOMP
C*SETC*      CALL SETCAR(IMATOM, STRING)
       CAR(IMATOM)= STRING 
C*SETC*      CALL SETCDR(IMATOM, NIL)
       CDR(IMATOM)= NIL 
      PNP(IMATOM+1) = JBP+L
C*SETC*      IF (HADR.GT.0) CALL SETCAR(IMATOM, UNBOUN)
      IF (HADR.GT.0)  CAR(IMATOM)= UNBOUN 
      IF (HADR.GT.0) HTAB(HADR)  = IMATOM
      IF (ABUP1.EQ.0) GOTO 60
C                                      MOVE CHARS TO PNAME
      DO 42 J = 1,ABUP1
         CALL PUTCH(PNAME,ABUFF(J),JBP)
42       JBP = JBP+1
      GOTO 60
C             SPACE FOR NEW ATOM TOO SMALL.
C             PERFORM COMPACTING ATOM GBC.
50    NALEFT = GARB(3)-1
      NBLEFT = BYTES*(NUMBP-2)-(JBP-1)-L
      IF (NALEFT.LT.0 .OR. NBLEFT.LT.0) GOTO 56
      IF (.NOT.IBREAK) ERRTYP = 0
      IF (NALEFT.LT.10) ERRTYP = 28
      IF (NBLEFT.LT.50) ERRTYP = 37
      IF (ERRTYP.GT.0) IBREAK = .TRUE.
      IF (HADR) 35, 35, 100
C                                      ATOM SPACE EMPTY. NIL RETURNED
56    ERRTYP = 33
      IBREAK = .TRUE.
      IMATOM = NIL
C               RESET POINTER IN ABUFF AND RETURN(IMATOM)
60      ABUP1=0
      MATOM = IMATOM
        RETURN
        END
      INTEGER FUNCTION MKNUM(N)
        INCLUDE 'F4COM.FOR'
C
C               ROUTINE FOR MAKING A BIG INTEGER NUMBER.
C
      IF (N.LT.-ISMALL .OR. N.GT.ISMALL) GOTO 1
      MKNUM = N+NUMADD
      RETURN
1     MKNUM = MKREAL(FLOAT(N))
      RETURN
      END
      FUNCTION MKREAL(R)
        INCLUDE 'F4COM.FOR'
C
C                    ROUTINE FOR MAKING A FLOATING NUMBER
C
      INTEGER GARB
C                                      CHECK PRINTNAME SPACE
1     IF (IBREAK .AND. ERRTYP.EQ.25) GOTO 3
      NLEFT = NUMBP-(JBP-2)/BYTES-4
      IF (NLEFT.GE.0 .AND. NLEFT.NE.9) GOTO 11
      I = GARB(3)
C                                      CHECK AFTER GARB
      NLEFT = NUMBP-(JBP-2)/BYTES-4
      I = NUMBP-DPNP-3
      IF (I.LT.NLEFT) NLEFT = I
      GOTO 12
C                                      CHECK BIGNUM SPACE
11    NLEFT = NUMBP-DPNP-3
      IF (NLEFT.GE.0 .AND. NLEFT.NE.9) GOTO 2
      NLEFT = GARB(2)-1
12    IF (NLEFT.LT.0) GOTO 3
      IF (NLEFT.GE.10) GOTO 2
      ERRTYP = 21
      IBREAK = .TRUE.
C                                      MAKE THE NUMBER
2     NUMBP = NUMBP-1
      PNAME(NUMBP) = R
      MKREAL = NUMBP-DPNAME
      RETURN
C                                      BIGNUM SPACE EMPTY. 0 RETURNED
3     ERRTYP = 25
      IBREAK = .TRUE.
      MKREAL = NUMADD
      RETURN
      END
      INTEGER FUNCTION GETNUM(I)
        INCLUDE 'F4COM.FOR'
      IF (I.GT.BIGNUM) GOTO 1
      R = GTREAL(I,IRETUR)
      GETNUM = IRETUR
      RETURN
1     GETNUM = I-NUMADD
      RETURN
      END
      FUNCTION GTREAL(I,IRETUR)
        INCLUDE 'F4COM.FOR'
      IF (I.GT.BIGNUM) GOTO 1
      J = I+DPNAME
      R = PNAME(J)
      IRETUR = MAXBIG
      IF (R.LT.0.) IRETUR = -IRETUR
      IF (ABS(R).LT.BIGMAX) IRETUR = INT(R)
      GTREAL = R
      RETURN
C                                      SMALL INT. -- DON'T CONVERT
1     GTREAL = 0.
      IRETUR = I-NUMADD
      RETURN
      END
      INTEGER FUNCTION GETCHT(IC)
        INCLUDE 'F4COM.FOR'
      I = IC/CHDIV+1
      IF (IC.LT.0) I = NBYTES+I-1
      GETCHT=CHTAB(I)
      RETURN
      END
         SUBROUTINE SETCHT(IC,IT)
        INCLUDE 'F4COM.FOR'
      DIMENSION ICH(24)
      EQUIVALENCE (SPACE,ICH(1))
      I = IC/CHDIV+1
      IF (IC.LT.0) I = NBYTES+I-1
      CHTAB(I)=IT
      ICH(IT)=IC
      RETURN
      END
      INTEGER FUNCTION NCHARS(S,IFLG)
        INCLUDE 'F4COM.FOR'
      INTEGER S,CONS
      CALL APUSH(PRTPOS)
      DO 1 I=1,MARG
         BUFF(I)=PRBUFF(I)
1        PRBUFF(I)=SPACE
      I = DREG(5)
      DREG(5)=IFLG
      IFLG1=NUMADD
      PRTPOS=1
2     IF (S.LE.NIL) GOTO 4
      IF (S.LE.NATOM .OR. S.GT.NFREET) S=CONS(S,NIL)
3     ICAR=CAR(S)
      CALL PRIN1(ICAR)
      S=CDR(S)
      GOTO 2
4     NCHARS = MKNUM(IFLG1+PRTPOS-1-NUMADD)
      IFLG1=NIL
      DREG(5) = I
      RETURN
C             AFTER CALLING NCHARS, NCHARS=THE NUMBER OF CHARS IN S,
C             PRBUFF=THE PRINTNAME OF S, BUFF=OLD PRBUFF.
C             CALLING ROUTINE MUST RESET PRBUFF AND PRTPOS
      END
      SUBROUTINE LSPEX
        INCLUDE 'F4COM.FOR'
C             EXIT ROUTINE
      INTEGER CONS
      LMARG = 12
      CALL TERPRI
      CALL MESS(4)
      CALL MESS(39)
      LUNUT = LUNUTS
      CALL IPRINT(CONS(MKNUM(GARBS),
     *              CONS(MKNUM(CGARBS),
     *                CONS(MKNUM(NGARBS),
     *                  CONS(MKNUM(AGARBS), NIL)))))
      CALL MESS(30)
      IF (.FALSE.) RETURN
      LMARG = 1
C        LINE ABOVE NEEDED IF YOU CAN SAVE CORE IMAGES
C        THAT YOU RUN AGAIN
      STOP
      END
      SUBROUTINE MESS(I)
        INCLUDE 'F4COM.FOR'
      IF (I.EQ.0) GOTO 10
      IF (I.GT.MAXMES) I = 31
1     NW = NBMESS/IBYTES
      I2 = NW*I
      CALL WRA4(LUNUTS,IMESS,(I2+1)-NW,I2)
      RETURN
C             READ MESSAGES FROM LUNSYS
10    I1=1
      I2 = NBMESS/IBYTES
      I3 = I2
      DO 20 K=1,MAXMES
      CALL RDA4(LUNSYS,IMESS,I1,I2)
      I1=I1 + I3
20    I2=I2 + I3
      RETURN
      END
      SUBROUTINE DMPIN2(LUN,CARD,I1,I2)
C             DMPIN2 IS CALLED ONLY FROM ROLLIN.
C             CARD MUST HAVE THE SAME DECLARATION AS CAR, CDR ...
        INCLUDE 'F4COM.FOR'
      INTEGER*2 CARD(I2)
C      I3 = MAXREC/JBYTES
C      DO 10 I = I1,I2,I3
C        MAX = I+I3-1
C        IF (MAX.GT.I2) MAX = I2
C10      READ (LUN) (CARD(J), J = I,MAX)
10       READ (LUN) (CARD(J), J = I1,I2)
      RETURN
      END
      SUBROUTINE RDA4(LUN,CARD,I1,I2)
      INTEGER CARD(I2)
C             RDA4 IS CALLED FROM MESS
      READ(LUN,100) (CARD(I),I=I1,I2)
100   FORMAT (100A5)
      RETURN
      END
      SUBROUTINE DMPIN (LUN,AREA,I1,I2)
        INCLUDE 'F4COM.FOR'
      INTEGER AREA(I2)
C      I3 = MAXREC/IBYTES
C      DO 10 I = I1,I2,I3
C        MAX = I+I3-1
C        IF (MAX.GT.I2) MAX = I2
10       READ (LUN) (AREA(J), J = I1,I2)
        RETURN
        END
      SUBROUTINE DMPOU2(LUN,LINE,I1,I2)
C             DMPOU2 IS CALLED ONLY FROM ROLLOUT.
C            LINE MUST HAVE THE SAME DECLARATION AS CAR, CDR ...
        INCLUDE 'F4COM.FOR'
      INTEGER*2 LINE(I2)
C     IF YOUR FORTRAN HAS A MAX RECORD LENGTH WHEN WRITING TO FILES
C     YOU MAY HAVE TO CHANGE BELOW. REMOVE LINE 10 AND THE COMMENTS
C     CHANGE MAXREC TO WHATEVER LENGT IS MAX ON YOUR COMPUTER
C      I3 = MAXREC/JBYTES
C      DO 10 I = I1,I2,I3
C        MAX = I+I3-1
C        IF (MAX.GT.I2) MAX = I2
C10      WRITE (LUN) (LINE(J), J = I,MAX)
10       WRITE (LUN) (LINE(J), J = I1,I2)
      RETURN
      END
      SUBROUTINE WRA1(LUN,LINE,I1,I2)
      INTEGER LINE(I2)
      INCLUDE 'F4COM.FOR'
C INSERTED BY TR:
      IF(LUN.EQ.LUNUTS)GOTO 1
      WRITE(LUN,100) (LINE(I),I=I1,I2)
      RETURN
1      WRITE(LUN,101)(LINE(I),I=I1,I2)
101   FORMAT(1X,150A1)
100   FORMAT(150A1)
      RETURN
      END
      SUBROUTINE RDA1(LUN,CARD,I1,I2,IEOF)
C             CALLED FROM SHIFT AND INIT2
      INTEGER CARD(I2)
      INCLUDE 'F4COM.FOR'
      COMMON /PROMPT/PROTXT(80),PROLEN
      INTEGER PROTXT,PROLEN
      IEOF=1
      IF (LUN.NE.LUNINS) GOTO 40
      IF (PRTPOS.GT.1) GOTO 20
      WRITE (LUNUTS,10) (PROTXT(I),I=1,PROLEN)
10    FORMAT (1X,150A1)
      GOTO 40
20    K=PRTPOS-1
      WRITE(LUNUTS,101)(PRBUFF(I),I=1,K)
101   FORMAT(1X,150A1)
      DO 21 I=1,K
21    PRBUFF(I)=SPACE 
      PRTPOS=1
40    CONTINUE
      READ(LUN,100,END=1) (CARD(I),I=I1,I2)
100   FORMAT(150A1)
      RETURN
1     IEOF=2
      RETURN
      END
      FUNCTION MPNAME(X,BUFFER,MAX,IPL)
C-- MOVES THE PNAME OF X TO THE BUFFER IN PACKED FORM
C-- MPNAME LT 0  ERROR
C--        EQ 0  OK
C--        GT 0  TRUNCATION
      INCLUDE 'F4COM.FOR'
      INTEGER GETPN,X,BUFFER(1),MAX,IPL
      IF(GETPN(X,MAIN,JB,IPL).LT.0)GO TO 5
      DO 2 I=1,MAX
2     CALL PUTCH(BUFFER,1H ,I)
      MPNAME=0
      IF(IPL.LE.MAX)GO TO 3
      MPNAME=1
      IPL=MAX
3     DO 4 I=1,IPL
      CALL GETCH(PNAME,ICH,JB)
      CALL PUTCH(BUFFER,ICH,I)
4     JB=JB+1
      RETURN
5     MPNAME=-1
      RETURN
      END
      SUBROUTINE WRA4(LUN,LINE,I1,I2)
        INCLUDE 'F4COM.FOR/NOLIST'
      INTEGER LINE(I2)
        I3=1
        DO 10 I=I1,I2
          IF(LINE(I).NE.SPACE) I3=I
10        CONTINUE
        WRITE(LUN,101)(LINE(I),I=I1,I3)
101   FORMAT(1X,100A5)
      RETURN
      END
      SUBROUTINE DMPOUT(LUN,AREA,I1,I2)
        INCLUDE 'F4COM.FOR'
      INTEGER AREA(I2)
C      I3 = MAXREC/IBYTES
C      DO 10 I = I1,I2,I3
C        MAX = I+I3-1
C        IF (MAX.GT.I2) MAX = I2
10       WRITE (LUN) (AREA(J), J = I1,I2)
        RETURN
        END
******HEART       (HEART OF INTERPRETER)
      SUBROUTINE LISPF4(IREE)
      INCLUDE 'F4COM.FOR'
      COMMON /PROMPT/PROTXT(80),PROLEN
      INTEGER PROTXT,PROLEN
      INTEGER OPENF
C     THIS IS A MODIFIED LISPF3 THAT USE A STACK
C     AND NOT A A-LIST FOR VARIABLE BINDINGS.
C
C               LOCAL DECLARATIONS
C               ==================
C
      INTEGER ARGS(10)
      LOGICAL NLISTP,GREAT,SPECAT,APLYFL,NOEVAL,ILLENV,FORMFL
      INTEGER CONS,SUBPR,EQUAL,GET,GETCHT,GETPN,RATOM,COMPPN,
     * GARB,GETNUM,ROLLIN,XCALL,INDEX,IOTAB(10),IPNAME(1)
      INTEGER*2 JPNAME(1),JDUMMY
      REAL NARR(1),RARGS(1)
      EQUIVALENCE (LUNIN,IOTAB(1)),(IRES,ARG),(N,NARR(1))
      EQUIVALENCE (ARG,ARGS(1),RARGS(1)),(PNAME(1),IPNAME(1),JPNAME(1))
      NLISTP(IDUMMY) = IDUMMY.LE.NATOM .OR. IDUMMY.GT.NFREET
      GREAT(IDUMMY) = IDUMMY.LT.-ISMALL .OR. IDUMMY.GT.ISMALL
C      SPECAT(JDUMMY) = JDUMMY.EQ.STRING .OR. JDUMMY.EQ.SUBSTR
C     * .OR. JDUMMY.EQ.ARRAY
      SPECAT(JDUMMY) =  JDUMMY.LE.SUBSTR .AND. JDUMMY.GE.ARRAY
      NUPAIR(IDUMMY,IDUMMZ) = CONS(MKNUM(IDUMMY/IDUMMZ),
     *       MKNUM(MOD(IDUMMY,IDUMMZ)))
      ILLENV(II) = II.GT.TOPS .OR.(II.NE.0 .AND. JACK(II).GT.0)
2      GOTO (10,1 ,1 ),IREE
C          INI STA REE
10    CONTINUE
      CALL MESS(20)
      PRTPOS = 12
      CALL IPRINT(CONS(83+NUMADD, CONS(08+NUMADD, CONS(22+NUMADD,NIL))))
      CALL MESS(22)
      PRTPOS = 12
      I = NUMBP-DPNP-2
      J = NUMBP-(JBP-2)/BYTES-3
      IF (J.LT.I) I = J
      CALL IPRINT(CONS(MKNUM(NFREEP-NFREEB),
     *              CONS(NUMADD+ISMALL,
     *                CONS(MKNUM(I),
     *                  CONS(MKNUM(NATOM-NATOMP), NIL)))))
C               RESTART OF INTERPRETER
C               -----------------------------
1     IP = 1
      JP=NSTACK+1
      IPP=0
      JPP=0
      CALL MESS(17)
C*SETC*      CALL SETCAR(NIL,NIL)
       CAR(NIL)=NIL 
C*SETC*      CALL SETCDR(NIL,NIL)
       CDR(NIL)=NIL 
C*SETC*      CALL SETCAR(T,T)
       CAR(T)=T 
      IFLG1 = NUMADD
      CALL TERPRI
      IFLG1 = NIL
      IFLG2 = NIL
      CHT = 1
      RDPOS = 1000
      LUNIN=LUNINS
      FORM=NIL
      HILLW=HILL - 150
      MIDDL=NSTACK/10
      ISPLFT=400
      IBREAK=.FALSE.
      ARG = LISPX
      ARG2 = NIL
      ENV=0
      TOPS=0
      CALL GETCH(1H_,PROTXT(1),1)
      PROLEN=1
      GOTO 1500
C
C RECURSIVE RETURN PROCEDURE
C DROP TOP BLOCK
C
997   ENV=-JACK(TOPS)
C                                      ! RESTORE ENVIRONMENT
998   TOPS=JILL(TOPS)
C                                      ! DROP TOP BLOCK
999      I=STACK(IP)
         IP=IP-1
C
1000  GOTO (15013 ,2020  ,2620  ,2120  ,12185 ,997   ,1020  ,
     *      1710  ,1830  ,18060 ,20130 ,18100 ,18170 ,
     *      12260 ,18210 ,25090 ,25100 ,15010 ,998   ,12150 ,
     *      12290 ,12640 ,20095 ,1795  ,1778  ,1799  ,18012),I
C
C           APPLYS EVLIS  EVLAS  EVCON  EVSTK  &POPE  LISPX
C           EAPPL  FUNAR  SETQ   PROG   AND    OR
C           MAPC   SELEC  ?STOV  ?STUN  APPLA  &POP   EVALA  
C           MAPC   RPT    PROG   EVARGN EVARG  NOSP   FUNCTION   =27
C                             
      GOTO 25130
C                                        ! INTERNAL STACK PROBLEM
C
C
C RECURSIVE FUNCTION LISPX()
C-----------------------------------------------------------------------
C USE EVAL IN TOP LEVEL LOOP
C
1010  IBREAK=.FALSE.
      ARG=IREAD(0)
      CALL FPUSH(7)
      GOTO 1600
C
C--R7         RETURN POSITION FROM EVAL
C
1020  CALL IPRINT(IRES)
      CALL TERPRI
      GOTO 1010
C
C
C             RECURSIVE FUNCTION APPLY(ARG,ARG2)
C
1477  CALL FPUSH(19)
1500  IF (ARG.EQ.NIL) GOTO 999
      L=ARG
      APLYFL=.TRUE.
      ARG=CONS(L,ARG2)
      FORM=CONS(NIL,ARG)
      GOTO 1671
C                                      ! TO ENTRY EAPPLY(L,ARG2) IN EVAL
C
C               RECURSIVE FUNCTION EVAL(ARG)
C               ============================
C
1600  IF(IBREAK) GOTO 2400
      IF(TOPS.GT.HILLW) GOTO 25095
      IF(JP .LE. IP+MIDDL) GOTO 25090
C                                     ! THESE ARE THE ONLY
C                                     ! STACK-OVERFLOW TESTS NEEDED
      IF(ARG .GT. NATOM) GOTO 1660    
C                                     ! LIST OR NUMBER
      IF(ARG.EQ.NIL.OR.ARG.EQ.T)GOTO 999
      IF (SPECAT(CAR(ARG)))  GOTO 999
C
C            EVAL - ATOM.
C            ATOM NOT NIL, T, STRING,
C            ARRAY OR NUMBER. CHECK IF BOUND ON STACK
C
      LOCAL=ENV
      IF (LOCAL.LE.0)GOTO 1650
      GOTO 1620
1610  LOCAL=-JACK(LOCAL)
      IF (LOCAL.LE.0) GOTO 1650
1620  LOCALE=JILL(LOCAL)+2
      K=LOCAL
1630  K=K-1
      IF (K.LT.LOCALE) GOTO 1610
      IF (JACK(K).NE.ARG) GOTO 1630
      IRES=JILL(K)
      GOTO 999
C
C
C           ATOM NOT ON STACK CHECK VALUE CELL.
C
1650  IF(CAR(ARG).EQ.UNBOUN) GOTO 2200
C                                      ! 2200=FAULTEVAL(ARG)
      IRES=CAR(ARG)
      GOTO 999
C
C          HERE IF ARG NUMBER OR LIST
C          ==========================
C
1660  IF(ARG .GT. NFREET) GOTO 999 
C                                      ! IT'S A NUMBER
C
C              EVAL - LIST
C
      FORM=ARG
      L=CAR(ARG)
      ARG2=CDR(ARG)
C
C            EAPPLY(L,ARG2) . CALLED FROM EVAL AND FROM APPLY.
C
1670  APLYFL=.FALSE.
1671  LL=L
      IF(LL .GT. NATOM) GOTO 1720 
C                                      ! CAR OF FORM IS A LIST
C                                      ! HOPEFULLY (LAMBDA ...)
C                                      ! OR  (SUBR . ...)
C
C THE FOLLOWING CODE IS FOR AVOIDING CALLS TO GET FOR TESTING IF
C THERE IS ANY FUNCTION DEFINITION STORED UNDER THE FNCELL PROPERTY
      LL=CDR(L)
      IF(LL.EQ.NIL)GOTO 1676
      IF(CAR(LL).NE.FNCELL)GOTO 1677
      LL=CAR(CDR(LL))
      GOTO 1720
1677  LL=GET(L,FNCELL)
C                                      ! IS THERE ANYTHING IN FUNC.CELL?
      IF(LL .NE. NIL) GOTO 1720   
C                                      ! THERE WAS SOMETHING
1676  IF(L .GT. FSUBR) GOTO 2230  
C                                      ! 2230 = FAULTAPPLY(L)
      IF(L .GT. SUBR) GOTO 18000
C                                      ! 18000 = THE MATCH ROUTINE FOR FSUBRS.
      IF(L .EQ. NIL) GOTO 2230
C
C
C     SUBR CASE
C     =========
C
C      
C      1. PUT THE BOTOM BLOCK
C
1680  IPREV=TOPS
C                                      ! SAVE OLD TOPS
      TOPS=TOPS+1
      JACK(TOPS)=L
      JILL(TOPS)=ARG
C                                      ! WE PUSH *FORM AND ARG
C
C      2.  SPREAD THE ARGS
C
1690  IF (NLISTP (ARG2)) GOTO 1695
C                                      ! ARG2 HOLDS THE ARGLIST
      TOPS=TOPS+1
      JACK(TOPS)=SUBARG
      JILL(TOPS)=CAR(ARG2)
      ARG2=CDR(ARG2)
      GOTO 1690
C      3.  PUT TOP BLOCK
C
1695  TOPS=TOPS+1
      JACK(TOPS)=-IPREV    
C                                      ! LINK TO PREVIUS BLOCK
      JILL(TOPS)= IPREV+1
C                                      ! LINK TO FORM
      IF(APLYFL)GOTO 1713
C                                      ! DON'T EVALUATE ARGS IF
C                                      ! SUBR CALLED BY APPLY
C      CALL APUSH(L) INLINE
C      JP=JP-1
C      IF(IP .GE. JP) GO TO 2
C      STACK(JP)=L
C                                      ! WE SAVE L (THATS THE SUBR)
C                                      ! ON THE STACK OTHERVISE
C                                      ! IT IS HARD TO KNOW WHAT SUBR
C                                      ! WE HAD WHEN WE HAVE EVALUATED
C                                      ! THE ARGS TO THE SUBR
C           EVAL ARGS TO SUBR
C           =================
C           WHEN WE ARRIVE HERE THE TOP BLOCK MAY LOOK LIKE THIS.
C           THE GLOBAL VARIABLE TOPS POINTS TO THE TOPBLOCK.
C           THE POINTER IN JILL(TOPS) POINTS TO ARGUMENT UNDER
C           EVALUATION.
C
C           I--  LINK,,LINK -------------  <---  TOPS
C           I    -*-  FOO               I
C           I    -*-  BAR               I
C           I   *FORM (CONS FOO BAR)  <-I
C           I
C           I->  LINK,,LINK
C
1697  JILL(TOPS)=JILL(TOPS)+1
      IF(JILL(TOPS).EQ.TOPS)GOTO 1712
C                                      ! WE HAVE EVALUATED ALL ARGS
      ARG=JILL(JILL(TOPS))
      IP=IP+1
      STACK(IP)=8
C                                      !  CALL FPUSH(8)
      GOTO 1600
C R-8
1710  IF41=JILL(TOPS)
      JILL(IF41)=IRES
      GOTO 1697
C
1712  CONTINUE
C     OK WE ARE READY NOW WE MUST
C     1. COMPUTE INDEX TO FIRST ARG
C     2. RESTORE FORM
C     3. RESTORE FUNCTION (=L)
C     4. FIX LINK TO PREVIUS BLOCK
C     5. COMPUTE NUMBER OF ARGS
      INDEX=-JACK(TOPS)
C                                      ! THATS TO PREVIUS BLOCK SO WE MUST
C                                      ! ADD 2 TO GET THE REAL INDEX
C                                      ! BUT WE CAN USE THIS INDEX FIRST
      IF41=INDEX+1
      FORM=JILL(IF41)
      L=JACK(IF41)
      JACK(IF41)=SFORM
C
C      CALL APOP(L) INLINE
C      IF (JP .GT. NSTACK) GO TO 2
C      L=STACK(JP)
C      JP=JP+1
C
      JILL(TOPS)=INDEX
      JACK(TOPS)=0
C                                      ! JACK = 0 SHOWS THIS BLOCK
C                                      ! HAS NO VARIABLES
C
      INDEX=INDEX+2
      IARGS=TOPS-INDEX
      GOTO 2800
C                                      ! 2800 THE DISPATCH FOR SUBRS
C
C     SUBR CALLED FROM APPLY
C
C     WE DO THE SAME THING BUT WE DONT HAVE TO
C     RESTORE FORM OR FUNCTION
C
1713  INDEX=-JACK(TOPS)
      JILL(TOPS)=INDEX
      JACK(TOPS)=0
      INDEX=INDEX+2
      IARGS=TOPS-INDEX
      GOTO 2800
C                                      ! 2800 THE DISPATCH FOR SUBRS
C
C
C               APPLYFN2(LL,ARG2)
C               APPLIES A LIST FORM ONTO ARG2
C               LL IS (HOPFULLY) ON FORM (LAMBDA (X Y) .....)
C                                        OR (SUBR . ...)
C               ARG2 IS A LIST OF PARAMETERS
C
1720  IF (NLISTP(LL)) GOTO 2210
C                                      ! 2210=FAULTAPPLY(LL)
      L=CAR(LL)
      IF(L .EQ. LAMBDA) GOTO 1730
      IF(L .EQ. NLAMBD) GOTO 1722
C  (SUBR . X) CASE
      IF(L .EQ. EXPR  ) GOTO 1810
C  (FSUBR . X) CASE
      IF(L .EQ. FEXPR)  GOTO 1815
      IF(L .EQ. FUNARG) GOTO 1818
      GOTO 2210
C
1722  NOEVAL=.TRUE.
      GOTO 1731
1730  NOEVAL=.FALSE.
C
C
C          LAMBDA & NLAMBDA CASE
C          =====================
C
C          1. BOTTOM BLOCK
C
1731  IPREV=TOPS
C                                      ! THIS IS PREVIUS BLOCK
      TOPS=TOPS+1
      JACK(TOPS)=SFORM
      JILL(TOPS)=ARG
C                                      ! PUSH FORM ON STACK
C           2. FIND THE LAMBDALIST
C
C           IF THE FORM IS (FOO FIE FUM (SETQ BAR 77))
C           AND FOO  = (DE FOO (X Y)(CONS X Y))
C           THEN LL  = (LAMBDA (X Y)(CONS X Y))
C           AND ARG2 = (FIE FUM (SETQ BAR 77))
C
1750  ICDR=CDR(LL)
      ICAR=CAR(ICDR)
C                                      ! ICAR IS THEN (X Y)
1760  IF(NLISTP(ICAR))GOTO 1770
C                                      ! THERE WERE NO LAMBDALIST
C                                      ! OR IT IS EXAUSTED
      TOPS=TOPS+1
      JACK(TOPS)=CAR(ICAR)
      JILL(TOPS)=CAR(ARG2)
      ARG2=CDR(ARG2)
      ICAR=CDR(ICAR)
      GOTO 1760 
C
1770  IF(ICAR.NE.NIL) GOTO 1789
C                                      ! WE HAVE A LAMBDA LIST ON FORMAT
C                                      ! (X Y . Z), HALFSPREAD OR L, NOSPREAD
C
C          WE ARE ABOUT TO PUT THE TOPBLOCK
C          BUT MAYBE ARE THERE EXTRA ARGUMENTS TO THE FUNCTION
C
1771  IF (NLISTP(ARG2)) GOTO 1772
C                                      ! THERE WERE NO EXTRA ARGS
C          SOMEONE HAS CALLED A LAMBDA WITH MORE ARGUMENTS
C          THAN DEFINED IN LAMBDALIST.
C          WE PUT THE EXTRA ARGS ABOVE THE "REAL" ONES.
C          THESE ARGS ALL GET THE NAME -*-
C
      TOPS=TOPS+1
      JACK(TOPS)=SUBARG
      JILL(TOPS)=CAR(ARG2)
      ARG2=CDR(ARG2)
      GOTO 1771
C
C             NOW WE CAN PUT THE TOP BLOCK
C
1772  TOPS=TOPS+1
      JACK(TOPS)=-IPREV
C                                      ! TO PREVIUS BLOCK
      JILL(TOPS)=IPREV+1
C                                      ! TO FORM
      IF(NOEVAL.OR.APLYFL)GOTO 1785
C                                      ! IT WAS A NLAMBDA
C                                      ! OR FUNCTION CALLED BY APPLY
C
C
C              EVALUATE ALL ARGS
C              =================
C
C              WHEN WE ARRIVE HERE THE TOP BLOCK MAY LOOK LIKE THIS.
C              THE GLOBAL VARIABLE TOPS POINTS TO THE TOPBLOCK
C
C              I--  LINK,,LINK -------------------------  <---  TOPS
C              I    -*- (SETQ BAR 77)                   I
C              I     Y  FUM                             I
C              I     X  FIE                             I
C              I   *FORM (FOO FIE FUM (SETQ BAR 77))  <-I
C              I
C              I->  LINK,,LINK
C
1777  JILL(TOPS)=JILL(TOPS)+1
      IF (JILL(TOPS).EQ.TOPS) GOTO 1785
      IF41=JILL(TOPS)
      ARG=JILL(IF41)
      IP=IP+1
      STACK(IP)=25
C                                         !  CALL FPUSH(25)
      GOTO 1600
C R-25
1778  IF41=JILL(TOPS)
      JILL(IF41)=IRES
      GOTO 1777
C
C
C          WE HAVE EVALUATED ALL ARGS
C          ==========================
C
C          WE MUST NOW
C          FIX LINK TO PREVIUS BLOCK
C          SAVE THE OLD ENVIRONMENT
C          MAKE THIS THE NEW ENVIRONMENT
C          RESTORE FORM AND FUNCTION
C
1785  INDEX=-JACK(TOPS)
      JILL(TOPS)=INDEX
      JACK(TOPS)=-ENV
      ENV=TOPS
      FORM=JILL(INDEX+1)
      L=CAR(FORM)
1776  IF(NLISTP(L)) GOTO 1786
      LL=L
      TEMP1=CAR(L)
      IF(TEMP1.NE.FUNARG) GOTO 1788
      TEMP1=CDR(L)
      L=CAR(TEMP1)
      GOTO 1776
C THE FOLLOWING CODE IS FOR AVOIDING CALLS TO GET
1786  LL=CDR(L)
C ASSUME THAT THERE IS ALWAYS A PROPERTY LIST
      IF(CAR(LL).NE.FNCELL)GOTO 1787
      LL=CAR(CDR(LL))
      GOTO 1788
1787  LL=GET(L,FNCELL)
1788  ARG=CDR(LL)
      ARG=CDR(ARG)
C
C           NOW ITS TIME TO CALL EVLAST WITH THE FUNCTION BODY
C           AND WHEN WE RETURN FROM THERE GOTO 997 TO POP ENVIRONMENT.
C           THIS WE COULD HAVE DONE WITH
C           CALL FPUSH(?)
C           GOTO 2600
C  R- ?
CXXXX       GOTO 997
C
C      BUT AS FPUSH(6) RETURNS TO 997 WE SAVE ONE RECURSION BY
C
       CALL FPUSH(6)
       GOTO 2600
C
C     HALF AND NOSPREAD ARGS
C     ======================
C
1789  TOPS=TOPS+1
      JACK(TOPS)=ICAR
      JILL(TOPS)=ARG2
C                                         ! PUT THE LAST ARG (HALFSPREAD)
C                                         ! OR THE ONLY ARG (NOSPREAD)
      TOPS=TOPS+1
      JACK(TOPS)=-IPREV
      JILL(TOPS)=IPREV+1
      IF(NOEVAL.OR.APLYFL) GOTO 1785
1790  JILL(TOPS)=JILL(TOPS)+1
      IF (JILL(TOPS).EQ.TOPS-1) GOTO 1797 
C                                         ! LAST ARGUMENT
      IF41=JILL(TOPS)
      ARG=JILL(IF41)
      IP=IP+1
      STACK(IP)=24
C                                         ! CALL FPUSH(24)
      GOTO 1600
C --R24
1795  IF41=JILL(TOPS)
      JILL(IF41)=IRES
      GOTO 1790
C
1797  ARG=JILL(TOPS-1)
      CALL FPUSH(26)
      GOTO 2000
C                                          ! CALL EVLIS WITH LAST OR
C                                          ! THE ONLY ARG
C R--26
1799  JILL(TOPS-1)=IRES
      GOTO 1785
C
C
C
C
C          (SUBR . ATOM)
1810  L=CDR(LL)
      IF(L .GT. SUBR) GOTO 2210
C                                         ! 2210=FAULTAPPLY(LL)
      IF (L.EQ.NIL) GOTO 2230
      GOTO 1680
C          (FSUBR . ATOM)
1815  L=CDR(LL)
      IF(L .GT. FSUBR) GOTO 2210
      IF(L .LE. SUBR) GOTO 2210
      GOTO 18000
C                                          ! 18000=MATCH ROUTINE FOR FSUBRS.
C
C
C               FUNARG
C              THIS CODE MUST BE REWRITEN IT WORKS BUT !!
1818  CONTINUE
      TEMP1=CDR(LL) 
      IF(NLISTP(TEMP1))TEMP1=NIL
      L=CAR(TEMP1)
      IF(NLISTP(TEMP1))TEMP1=NIL
      TEMP1=CDR(TEMP1)
      TEMP2=CAR(TEMP1)
1820  CONTINUE
      IPREV=TOPS
      TOPS=TOPS+1
      JACK(TOPS)=SFORM
c      JILL(TOPS)=TEMP1 !! THIS LINE CHANGED TO BELOW LINE, 20 OCTOBER 84
      JILL(TOPS)=LL
1821  TEMP3=CAR(TEMP2)
      IF(NLISTP(TEMP3)) GOTO 1822
      TOPS=TOPS+1
      TEMP2=CDR(TEMP2)
      JACK(TOPS)=CAR(TEMP3)
      JILL(TOPS)=CDR(TEMP3)
      GOTO 1821
1822  TOPS=TOPS+1
      JACK(TOPS)=-ENV
      JILL(TOPS)=IPREV
      ENV=TOPS
      APLYFL=.FALSE.
      CALL FPUSH(9)
      GOTO 1671
C
C--R9   
C
1830  K=JILL(TOPS)+1
      TEMP1=JILL(K)
      IF(NLISTP(TEMP1))GOTO 2250
      TEMP1=CDR(TEMP1)
      IF(NLISTP(TEMP1))GOTO 2250
      TEMP1=CDR(TEMP1)
      IF(NLISTP(TEMP1))GOTO 2250
      TEMP1=CAR(TEMP1)
      K1=K

1832  K1=K1+1
      IF(K1.GE.TOPS)GOTO 997
      IF(NLISTP(TEMP1))GOTO 2250
      TEMP2=CAR(TEMP1)
      IF(NLISTP(TEMP2))GOTO 2250
      IF(CAR(TEMP2).NE.JACK(K1)) GOTO 2250
C*SETC*      CALL SETCDR(TEMP2,JILL(K1))
      CDR(TEMP2)=JILL(K1)
      TEMP1=CDR(TEMP1)
      GOTO 1832

C
C
C
C             RECURSIVE FUNCTION EVLIS(ARG)
C-----------------------------------------------------------------------
C
2000  IF (NLISTP(ARG)) GOTO 999
      JP=JP-2
      STACK(JP+1)=NIL
      STACK(JP)=ARG
C                                        ! CALL APUSH2(NIL,ARG)
2010  ARG=CAR(ARG)
      IP=IP+1
      STACK(IP)=2
C                                        ! CALL FPUSH(2)
      GOTO 1600
C
C--R2         RETURN FROM EVAL(ARG)
C
2020  TEMP1=STACK(JP+1)
      STACK(JP+1)=CONS(IRES,TEMP1)
      ICDR=STACK(JP)
      ARG=CDR(ICDR)
      IF (NLISTP(ARG)) GOTO 2030
      STACK(JP)=ARG
      GOTO 2010
2030  IRES=STACK(JP+1)
      JP=JP+2
C       DREVERSE IRES BEFORE RETURN.
      TEMP1=NIL
2040  TEMP2=CDR(IRES)
C*SETC*      CALL SETCDR(IRES,TEMP1)
       CDR(IRES)=TEMP1 
      IF(TEMP2 .EQ. NIL) GOTO 999
      TEMP1=IRES
      IRES=TEMP2
      GOTO 2040
C
C
C-----------------------------------------------------------------------
C             RECURSIVE FUNCTION EVCON
C
2100  JP=JP-1
2110  STACK(JP)=ARG
      IF (NLISTP(ARG)) GOTO 2140
      ICAR=CAR(ARG)
      IF (NLISTP(ICAR)) GOTO 25080
      ARG=CAR(ICAR)
      IP=IP+1
      STACK(IP)=4
      GOTO 1600
C
C--R4         RETURN FROM EVAL(ARG)
C
2120  IF(IRES .NE. NIL) GOTO 2130
      ICDR=STACK(JP)
      ARG=CDR(ICDR)
      GOTO 2110
2130  ICAR=STACK(JP)
      ICAR=CAR(ICAR)
      ICAR=CDR(ICAR)
      JP=JP+1
      IF(ICAR .EQ. NIL) GOTO 999 
      ARG=ICAR
      GOTO 2600
2140  JP=JP+1
      IRES=NIL
      GOTO 999
C
C
C
C               FAULTEVAL AND FAULTAPPLY AS CALLED FROM EVAL-APPLY.
C               ---------------------------------------------------
C
2200  L=EVAL
      ERRTYP=1
      FORM=ARG
      GOTO 2400
C
2210  ARG=LL
      ERRTYP = 2
2220  L=APPLY
      GOTO 2400
C
2230  ARG=L
      ERRTYP=2
      GOTO 2220
C
2240  ERRTYP=26
      ARG=ARG2
      GOTO 2400
C
C  FAULTY FUNARG BLOCK
C
2250  ERRTYP=31
      FORM=JILL(JILL(TOPS)+1)
      L=CAR(FORM)
      ARG=NIL
      GOTO 2400

C
C       SYSERROR(ERRTYP,L,ARG,FORM)
C       ---------------------------
C       THIS ENTRY IS USED FOR ALL WEAK ERRORS IN THE SYSTEM.
C       WHEN CALLED, ERRTYP=TYPE OF ERROR, L=FAILING FUNCTION,
C         ARG=ERRONEOUS FORM, FORM=FORM BEING EVALUATED.
C       HERE THE LISP-DEFINED FUNCTION SYSERROR IS CALLED.
2400  ARG2=CONS(FORM,NIL)
      ARG2=CONS(ARG,ARG2)
      ARG2=CONS(L,ARG2)
      ARG2=CONS(ERRTYP+NUMADD,ARG2)
      ARG=ERROR
      IBREAK=.FALSE.
      LMARG=1
      GOTO 1500
C       CALL APPLY(SYSERROR, (ERRTYP L ARG FORM))
C
C
C
C
C             RECURSIVE FUNCTION EVLAST(ARG)
C-----------------------------------------------------------------------
C
C   ON ENTRY HERE ARG HOLDS A LIST OF FORMS THAT SHOULD BE EVALUATED
C   (SETQ FOO 77)(...) (....)
C   THE LIST IS KEEPT ON TOP OF STACK AND CAR OF IT IS SENT TO EVAL
C   WHEN ONLY ONE FORM IS LEFT THIS FORM IS GIVEN TO EVAL BUT BEFORE
C   THE TOP OF STACK IS CLEARED AND EVAL IS CALLED NONRECURCIVLY
C
2600  IF (NLISTP(ARG)) GOTO 999
      JP=JP-1
      STACK(JP)=ARG
      TEMP1=ARG
2610  ARG=CAR(TEMP1)
      I = CDR(TEMP1)
      IF (NLISTP(I)) GOTO 2630
      IP=IP+1
      STACK(IP)=3
      GOTO 1600
C
C--R3         RETURN FROM EVAL(ARG)
C
2620  ICAR=STACK(JP)
      TEMP1=CDR(ICAR)
      STACK(JP)=TEMP1
      GOTO 2610
2630  JP=JP+1
      GOTO 1600
C
C             MAIN DISPATCH
C             =============
C
C             AT ENTRY , L=THE FUNCTION, IARGS=NR OF ARGS IN
C             JILL ,STARTING AT INDEX
C
C
2800  IF (L.LE.SUBR0) GOTO 3000
      IF (L.LE.SUBR1) GOTO 3020
      IF (L.LE.SUBR2) GOTO 3140
      IF (L-SUBR3) 3200,3200,3290
C-----------------------------------------------------------------------
C SUBR0  ENTRY
C
3000  GOTO( 3090,10075,
     *     10080,10130,10050,10060,10070, 1010,10090,10100,10000,
     *     10105,1    ,10110 ,10120),L
C          NIL    BTV*  
C          CLOCK DATE  EJECT EXIT GENSY LISPX RATOM READ  READC
C          READP  RESET TERPRI TIME
C-----------------------------------------------------------------------
C SUBR1  ENTRY
C
3020  ARG=NIL
      IF (IARGS.EQ.0) GOTO 3050
3040  ARG=JILL(INDEX)
C
C SUBR1 JUMP ENTRY
C
3050  IF (L.LE.SUBR11) GOTO 3070
       LL=L-SUBR11
C             JUMP TO SUBR1 (AND DO NOT TEST ON NUM ARG)
      GOTO (10040,11190,11197,11200,
     *     11210,11210,11210,11210,11210,11210,11210,11210,11210,
     *     11210,11210,11210,11210,11210,11215,11220,11225,11227,11230,
     *     11255,11260,11290,11205,11310,11320,11330,11340,
     *     998,11355,20150,11360,11415,11420),LL
C          ALIST ARRAYSIZE ARRAYP ATOM
C          CAR   CDR   CAAR  CADR  CDAR  CDDR  CAAAR CAADR CADAR
C          CADDR CDAAR CDADR CDDAR CDDDR EVAL EVLIS FIXP FLOATP GETD
C          LAST,LENGTH LISTP LITAT NLISTP NULL  NUMBE OBLIS
C          PROG1 PROMP RETUR REVER STRINGP ZEROP
C
C SUBR1  TEST ON NUMERICAL ARG
C
3070  IF (ARG.LE.BIGNUM) GOTO 25000
      N = ARG-NUMADD
      LL=L-SUBR0
      GOTO(11000,11010,11020,11050,11060,11070,11080),LL
C          ADD1 ERRMS RECLA ROLLI ROLLO SUB1 REWIND
C
C RETURN CHANNELS (CAN BE USED BY ALL SUBR'S AND FSUBR'S EXCEPT SUBRN'S)
C
C TEMP1
C
3080  IRES = TEMP1
      GOTO 998
C
C PREDICATES
C
3090  IRES=NIL
      GOTO 998
3100  IRES=T
      GOTO 998
C
C NUMERICAL VALUED FUNCTIONS
C
3105  CONTINUE
3110  IF(IRFLAG.NE.NIL) GOTO 3120
      IF (GREAT(N)) GOTO 3130
      IRES = N+NUMADD
      GOTO 998
3120  IRES = MKREAL(R)
      GOTO 998
3130  IRES=MKNUM(N)
      GOTO 998
C-----------------------------------------------------------------------
C SUBR2  ENTRY
C
3140  ARG2=NIL
      ARG=NIL
      IF41=IARGS+1
      GOTO (3190,3180,3170), IF41
3170  ARG2=JILL(INDEX+1)
3180  ARG=JILL(INDEX)
C
C SUBR 2 JUMP ENTRY
C
3190  LL=L-SUBR1
      GOTO  (12000,12040,12050,1477 ,12715,12720,12090,12100,12112,
     * 12114,
     * 12116,12120,12130,12140,12160,12190,12200,12730,12205,12210,
     * 12350,12390,12430,12470,12500,12510,12515,12520,12540,12570,
     * 12600,
     * 12620,12655,12660,12690,12746,12750,12780), LL
C            ADDLI ALPHO APPEN APPLY ASSOC   CHTAB CONS  DIFFE ELT
C      ELTI
C      ELTR  EQ    EQUAL EVALA EVSTK GETP  GREAT IOTAB IQUOR LESSP
C      MEMB  MEMBE NCHAR NCONC NCONC1 NEQ  NTH   PACK  QUOTI RPLACA 
C      RPLACD
C      RPT   SASSOC SET   STRAL TAILP UNPAC XCALL
C-----------------------------------------------------------------------
C SUBR3  ENTRY
C
3200  ARG=NIL
      ARG2=NIL
      ARG3=NIL
      IF41 = IARGS + 1
      GOTO (3280,3209,3207,3205), IF41
3205  ARG3=JILL(INDEX+2)
3207  ARG2=JILL(INDEX+1)
3209  ARG =JILL(INDEX)
C
C SUBR3  JUMP ENTRY
C
3280  LL=L-SUBR2
      GOTO  (15000,15012,15015,12330,12220,12310,12340 ,12345,15020,
     *15040, 15130,15142,15144,15146,15150,15160,15190), LL
C            APPLYA APPLYS ARRAY MAP  MAPC  MAPCA MAPLI OPEN0 PRIN0 
C     PUT    RPLST SETA  SETI  SETR SUBPAIR SUBSTR SYSERROR
C-----------------------------------------------------------------------
C SUBRN  ENTRY
C
C             IT IS HERE UP TO THE SUBRN TO TAKE CARE OF THE ARGS
C
3290  LL=L-SUBR3
      GOTO (16000,16010,16040,16070,16080), LL
C          CONCAT LIST  PLUS SYSFLA TIMES
C
C RETURN CHANNELS (3105 ALSO)
3300  CONTINUE
      IF(IFLG2-NIL) 16005,998,16005
C-----------------------------------------------------------------------
C             SUBR 0
C-----------------------------------------------------------------------
C
C READC
C
10010 CALL SHIFT(2)
10000 IF (CHT.LE.0) GOTO 10010
      IF (CHT.LT.13 .OR. CHT.GE.23) GOTO 10020
      IRES=CHT-13+NUMADD
      GOTO 10030
10020 ABUFF(1) = CHR
      IRES=MATOM(1)
10030 CALL SHIFT(2)
      GOTO 998
C
C ALIST
C
10040 LOCAL=ENV
      FORMFL = ARG.NE.NIL
      TEMP1=CONS(NIL,NIL)
      TEMP2=TEMP1
      IF (LOCAL.LE.0)GOTO 10044
      GOTO 10042
10041 IF(.NOT.FORMFL) GOTO 10037
      IF(JACK(K).NE.SFORM)GOTO 10037
C*SETC*      CALL SETCDR(TEMP1,CONS(CONS(JACK(K),JILL(K)),NIL))
       CDR(TEMP1)=CONS(CONS(JACK(K),JILL(K)),NIL) 
      TEMP1=CDR(TEMP1)
10037 LOCAL=-JACK(LOCAL)
      IF(LOCAL.LE.0)GOTO 10044
10042 LOCALE=JILL(LOCAL)+2
      K=LOCAL
10043 K=K-1
      IF (K.LE.0) GOTO 10044
      IF (K.LT.LOCALE) GOTO 10041
C*SETC*      CALL SETCDR(TEMP1,CONS( CONS(JACK(K),JILL(K)),NIL))
       CDR(TEMP1)=CONS( CONS(JACK(K),JILL(K)),NIL) 
      TEMP1=CDR(TEMP1)
      GOTO 10043
10044 IRES=CDR(TEMP2)
      GOTO 998
C
C EJECT
C
10050 CALL EJECT(LUNUT)
      GOTO 3090
C
C EXIT
C
10060 CALL LSPEX
C
C GENSYM
C
10070 ARG=CONS(A000,CONS(MKNUM(NUMGEN),NIL))
      NUMGEN=NUMGEN+1
      ARG2=NIL
      GOTO 12520
C             TO PACK
C
C BTV*
10075 CALL SHOSTK(1)
      IRES=NIL
      GOTO 998
C
C CLOCK
C
10080 IRES=MKNUM(MSLFT(I))
      GOTO 998
C
C RATOM
C
10090 BRFLG = NIL
      I = RATOM(IRES,0)
      GOTO 998
C
C READ
C
10100 IRES=IREAD(0)
      GOTO 998
C
C READP
10105 IF(CHT.GT.1) GOTO 3100
      IF(RDPOS.GT.MARGR) GOTO 3090
      CALL SHIFT (2)
      GOTO 10105
C
C RESET = GOTO 1
C
C
C TERPRI
C
10110 CALL TERPRI
      PRTPOS=LMARG
      GOTO 3090
C
C TIME
10120  CALL MTIME(BUFF)
C                            CHANGE 5 IF YOUR TIME FORMAT IS NOT 5 LONG
       DO 10125 I=1,5
       CALL GETCH(BUFF,TEMP1,I)
       ABUFF(I)=TEMP1
10125  CONTINUE
C                    THE TWO 5'S BELOW MUST ALSO BE CHANGED
       ABUP1= 5
       IRES=MATOM(-5)
       GOTO 998
C
C DATE 
10130  CALL MDATE(BUFF)
C              YOU CAN CHANGE THE 10 IN THE DO STATEMENT BELOW IF YOU
C              HAVE A DATE FORMAT THAT IS NOT 10 CHARACTERS LONG
       DO 10135 I=1,10
       CALL GETCH(BUFF,TEMP1,I)
       ABUFF(I)=TEMP1
10135  CONTINUE
C              THE TWO OCCURENCES OF 10 BELOW MUST ALSO BE CHANGED
       ABUP1= 10
       IRES=MATOM(-10)
       GOTO 998
C-----------------------------------------------------------------------
C        SUBR 1 (WITH NUMERICAL ARG IN N)
C-----------------------------------------------------------------------
C
C ADD1
C
11000 N=N+1
      IRFLAG = NIL
      GOTO 3110
C
C ERRORMESS
C
11010 IF (N.LT.1 .OR. N.GT.MAXMES) GOTO 25000
      CALL MESS(N)
         GOTO 998
C
C RECLAIM
C
11020 DO 11030 I = 1,NARGS
            IF (I.EQ.4) GOTO 11030
            IF (I.NE.5) ARGS(I) = NIL
11030       CONTINUE
      IF (N.LT.0 .OR. N.GT.3) GOTO 25000
      IRES = MKNUM(GARB(N))
      GOTO 998
C
C ROLLIN
C
11050 IF (N.LT.1 .OR. N.GT.MAXLUN) GOTO 25000
      IRES = ROLLIN(N)
      IF(IRES .EQ. NIL) GOTO 998
      GOTO 1
C
C ROLLOUT
C
11060 IF (N.LT.1 .OR. N.GT.MAXLUN) GOTO 25000
      CALL ROLLOU(N)
      GOTO 998
C
C SUB1
C
11070 N=N-1
      IRFLAG = NIL
      GOTO 3110
C
C REWIND
C
11080 IF (N.LT.1 .OR. N.GT.MAXLUN) GOTO 25000
      CALL REW(N)
      GOTO 998
C-----------------------------------------------------------------------
C       SUBR 1 (OTHERS)
C-----------------------------------------------------------------------
C ALIST 10040
C
C ARRAYSIZE
C
11190 DO 11195 I = 1,3
11195 CALL ARRUTL(ARG,3,I,J,ARGS(I+5))
      IF (IBREAK) GOTO 2400
      IRES = CONS(MKNUM(TEMP1+TEMP2+TEMP3),
     *  CONS(MKNUM(TEMP2),CONS(MKNUM(TEMP3),NIL)))
      GOTO 998
C ARRAYP
11197 IF (ARG.GT.NATOM) GOTO 3090
      IF (CAR(ARG).EQ.ARRAY) GOTO 998
      GOTO 3090
C
C ATOM
C
11200 IF (ARG.GT.NFREET) GOTO 3100
11205 IF (ARG.GT.NATOM) GOTO 3090
      IF (SPECAT(CAR(ARG))) GOTO 3090
      GOTO 3100
C
C C...R
C
C      THE CODE BELOW MUST BE CHANGED IF CAR NO LONGER IS THE
C      FIFT NON-NUMERIC SUBR1.
C
11210 LL = LL-3
11211 IF (ARG.GT.NFREET) GOTO 25000
      I = MOD(LL,2)
      IF (I.EQ.0)  IRES = CAR(ARG)
      IF (I.NE.0)  IRES = CDR(ARG)
      LL = LL/2
      IF (LL-1) 998,998,11211
C
C EVAL
11215   IP=IP+1
        STACK(IP)=19
        GOTO 1600
C
C EVLIS
C
11220 IP=IP+1
      STACK(IP)=19
      GOTO 2000
C
C FIXP
11225 IF(ARG.LE.NFREET) GOTO 3090
      IF(ARG.GT.BIGNUM) GOTO 998
      GOTO 3090
C
C FLOATP
11227 IF(ARG.LE.NFREET) GOTO 3090
      IF(ARG.LE.BIGNUM) GOTO 998
      GOTO 3090
C
C GETD
C
11230 K=GET(ARG,FNCELL)
      IF(K .EQ. NIL) GOTO 11240
      IRES=K
      GOTO 998
11240 IF(ARG .GT. FSUBR) GOTO 3090
      IF(ARG .EQ. NIL) GOTO 3090
      IF(ARG .GT. SUBR) GOTO 11250
      IRES=CONS(EXPR,ARG)
      GOTO 998
11250 IRES=CONS(FEXPR,ARG)
      GOTO 998
C
C LAST
11255 IF(NLISTP(ARG))GOTO 998
11256 TEMP1=CDR(ARG)
      IF(NLISTP(TEMP1)) GOTO 998
      ARG=CDR(ARG)
      GOTO 11256
C
C LENGTH
C
11260 K = 0
11270 IF (NLISTP(ARG)) GOTO 11280
      K=K+1
      ARG=CDR(ARG)
      GOTO 11270
11280 IRES = MKNUM(K)
      GOTO 998
C
C LISTP
C
11290 IF (NLISTP(ARG)) GOTO 3090
      GOTO 998
C
C LITATOM = 11205
C
C NLISTP
C
11310 IF (NLISTP(ARG)) GOTO 3100
      GOTO 3090
C
C NULL
C
11320 IF(ARG.EQ.NIL)GOTO 3100
      GOTO 3090
C
C NUMBERP
C
11330 IF(ARG.LE.NFREET) GOTO 3090
      GOTO 998
C
C OBLIST
C
11340 MIN=ARG
      IRES=NIL
      DO 11350 I=MIN,NATOMP
      IF (.NOT.SPECAT(CAR(I))) IRES = CONS(I,IRES)
11350 CONTINUE
      GOTO 998
C
C                                           !  PROMPT SHOULD BE A COMMON
C PROMPTTEXT (STRING) = OLD STRING          !   BLOCK CONTAINING
C                                           !    CURRENT PROMPT CH
11355 IF(ARG.GT.NATOM) GOTO 3090
      II=ARG
      DO 11356 I=1,PROLEN
11356 ABUFF(I)=PROTXT(I)
      IRES=MATOM(PROLEN)
      IF (II.EQ.NIL)GOTO 998
      I= GETPN(II,MAIN,JB,PROLEN)
      IF(PROLEN.GT.80)PROLEN=80
      DO 11357 I=1,PROLEN
11357 CALL GETCH(PNAME,PROTXT(I),JB+I-1)
      GOTO 998
C
C PROG1 = GOTO 998
C RETURN = 20150
C
C REVERSE
C
11360 IRET=1
C          SEQUENCE USED ALSO BY APPEND
11370 IF (NLISTP(ARG)) GOTO 11410
      TEMP1=NIL
11390 ICAR=CAR(ARG)
      TEMP1=CONS(ICAR,TEMP1)
      ARG=CDR(ARG)
      IF (.NOT.NLISTP(ARG)) GOTO 11390
11400 IRES=TEMP1
C            RETURN LIST
      GOTO(998,12070),IRET
C             RETURN ATOM
11410 GOTO(998,12060),IRET
C
11415 CONTINUE 
      IF (ARG.GT.NATOM) GOTO 3090
      IF (CAR (ARG).EQ.STRING) GOTO 998
      IF (CAR (ARG).EQ.SUBSTR) GOTO 998
      GOTO 3090
C ZEROP
C
11420 IF (ARG.EQ.NUMADD)GOTO 3100
      GOTO 3090
C-----------------------------------------------------------------------
C             SUBR 2
C-----------------------------------------------------------------------
C
C ADDLIST
C
12000 I=ARG2
12010 IF (NLISTP(I)) GOTO 12020
      IF(ARG .EQ. CAR(I)) GOTO 12030
      I=CDR(I)
      GOTO 12010
12020 IRES=CONS(ARG,ARG2)
      GOTO 998
12030 IRES=ARG2
      GOTO 998
C
C ALPHORDER
C
C** CHANGED BY TR TO BE EQUIVALENT WITH INTERLISP
12040 IF(ARG .LE. NFREET .OR. ARG2 .LE. NFREET) GOTO 12041
      R=GTREAL(ARG,I)
      S=GTREAL(ARG2,J)
      IF(R.EQ.0.)R=FLOAT(I)
      IF(S.EQ.0.)S=FLOAT(J)
      IF(R-S) 3100,3100,3090
12041 IF (ARG .GT. NFREET) GOTO 3100
      IF (ARG2 .GT. NFREET) GOTO 3090
      IF(ARG .GT. NATOM) GOTO 3100
C            HERE ARG = LITERAL ATOM
      IF(ARG2 .GT. NATOM) GOTO 3100
C            HERE ALSO ARG2 = LITERAL ATOM
      IF (COMPPN(ARG,ARG2)) 3100,3100,3090
C
C APPEND
C
12050 IRET=2
      GOTO 11370
C             TO REVERSE
12060 IRES=ARG2
C             ATOM RETURNED
      GOTO 998
12070 I=CDR(ARG)
C             LIST RETURNED
C*SETC*      CALL SETCDR(ARG,ARG2)
       CDR(ARG)=ARG2 
      IF (I.EQ.NIL) GOTO 998
      ARG2=ARG
      ARG=I
      GOTO 12070
C
C
C CONS
C
12090 IRES=CONS(ARG,ARG2)
      GOTO 998
C
C DIFFERENCE
C
12100 IF (ARG.LE.NFREET) GOTO 25020
      IF (ARG2.LE.NFREET) GOTO 25010
      IRFLAG = NIL
      R = GTREAL(ARG,I)
      S = GTREAL(ARG2,J)
      IF (R.NE.0..OR.S.NE.0.) GOTO 12105
      N = I-J
      GOTO 3110
12105 IRFLAG = T
      IF (R.EQ.0.) R = FLOAT(I)
      IF (S.EQ.0.) S = FLOAT(J)
      R = R-S
      GOTO 3110
C
C ELT
C
12112 IF (ARG2.LE.NFREET) GOTO 25010
      CALL ARRUTL(ARG,1,1,GETNUM(ARG2),TEMP1)
      IF (IBREAK) GOTO 2400
      IRES = JPNAME(TEMP1)
      GOTO 998
C
C ELTI
C
12114 IF (ARG2.LE.NFREET) GOTO 25010
      CALL ARRUTL(ARG,1,2,GETNUM(ARG2),TEMP1)
      IF (IBREAK) GOTO 2400
      IRES = MKNUM(IPNAME(TEMP1))
      GOTO 998
C
C ELTR
C
12116 IF (ARG2.LE.NFREET) GOTO 25010
      CALL ARRUTL(ARG,1,3,GETNUM(ARG2),TEMP1)
      IF (IBREAK) GOTO 2400
      IRES = MKREAL(PNAME(TEMP1))
      GOTO 998
C
C EQ
C
12120 IF(ARG-ARG2) 3090, 3100, 3090
C
C EQUAL
C
12130 IRES=EQUAL(ARG,ARG2)
      GOTO 998
C
C EVALA
C
12140 IPREV=TOPS
      TOPS=TOPS+1
      JACK(TOPS)=SFORM
      JILL(TOPS)=ARG2
12141 TEMP1=CAR(ARG2)
      IF(NLISTP(TEMP1)) GOTO 12142
      IF(TOPS.GT.HILL-60)GOTO 12141
      TOPS=TOPS+1
      ARG2=CDR(ARG2)
      JACK(TOPS)=CAR(TEMP1)
      JILL(TOPS)=CDR(TEMP1)
      GOTO 12141
12142 TOPS=TOPS+1
      JACK(TOPS)=0
      JILL(TOPS)=IPREV
      CALL APUSH(ENV)
      ENV=TOPS
      CALL FPUSH(20)
      GOTO 1600
C--R20        RETURN FROM EVAL(ARG)
12150 CALL APOP(ENV)
      TOPS=JILL(TOPS)
      GOTO 998
C
C EVSTK
12160 IPREV=TOPS
      TEMP1=GETNUM(ARG2)
      IF (ILLENV(TEMP1)) GOTO 25035
      TOPS=TOPS+1
      JACK(TOPS)=-TEMP1
      JILL(TOPS)=IPREV
      CALL APUSH(ENV)
      ENV=TOPS
      CALL FPUSH(5)
      GOTO 1600
C R-5
12185 TOPS=JILL(TOPS)
      CALL APOP(ENV)
      GOTO 998
C GETP
C
12190 IRES=GET(ARG,ARG2)
      GOTO 998
C
C GREATERP
C
12200 IF(ARG .LE. NFREET) GOTO 25020
      IF(ARG2 .LE. NFREET) GOTO 25010
      R=GTREAL(ARG,I)
      S=GTREAL(ARG2,J)
      IF(R.EQ.0.) R=FLOAT(I)
      IF(S.EQ.0.) S=FLOAT(J)
      IF(R-S) 3090,3090,3100
C
C IQUOREM
C
12205 IF (ARG.LE.NFREET) GOTO 25020
      IF (ARG2.LE.NFREET) GOTO 25010
      J = GETNUM(ARG2)
      IF (J.EQ.0) GOTO 25010
      IRES = NUPAIR(GETNUM(ARG),J)
      GOTO 998
C
C LESSP
C
12210 IF(ARG .LE. NFREET) GOTO 25020
      IF(ARG2 .LE. NFREET) GOTO 25010
      R=GTREAL(ARG,I)
      S=GTREAL(ARG2,J)
      IF(R.EQ.0.) R=FLOAT(I)
      IF(S.EQ.0.) S=FLOAT(J)
      IF(R-S) 3100,3090,3090
C
C MAPC (ARG, ARG2, ARG3)
C
12220 I=1
12230 JP=JP-1
      STACK(JP)=I
C             SEQUENCE USED ALSO BY MAP, MAPCAR, MAPLIST
12240 JP=JP-3
      IF (NLISTP(ARG)) GOTO 12300
      STACK(JP+2)=ARG2
      STACK(JP+1)=ARG3
      STACK(JP)=ARG
12250 ICAR=ARG
      IF(STACK(JP+3) .EQ. 1 .OR. STACK(JP+3) .EQ. 3) ICAR=CAR(ARG)
      ARG3=STACK(JP+1)
      ARG=STACK(JP+2)
      ARG2=CONS(ICAR,NIL)
      CALL FPUSH(14)
      GOTO 1500
C
C--R14        RETURN FROM APPLY
C
12260 IF(STACK(JP+3) .LT. 3) GOTO 12270
      IST=STACK(JP+4)
C*SETC*      CALL SETCDR(IST,CONS(IRES,NIL))
       CDR(IST)=CONS(IRES,NIL) 
      STACK(JP+4)=CDR(IST)
12270 ARG2=STACK(JP)
      ARG=STACK(JP+1)
      IF(ARG .EQ. NIL) GOTO 12280
C        THIRD ARGUMENT NOT NIL. APPLY STEP FUNCTION
      ARG2=CONS(ARG2,NIL)
      CALL FPUSH(21)
      GOTO 1500
12280    ARG=CDR(ARG2)
C
C--R21        RETURN FROM APPLY(ARG,ARG2)
C
12290 IF (NLISTP(ARG)) GOTO 12300
      STACK(JP)=ARG
      GOTO 12250
12300 JP=JP+4
      IF(STACK(JP-1) .LT. 3) GOTO 3090
      ICAR=STACK(JP)
C*SETC*      CALL SETCDR(ICAR,ARG)
       CDR(ICAR)=ARG 
      ICAR=STACK(JP+1)
      IRES=CDR(ICAR)
      JP=JP+2
      GOTO 998
C
C MAPCAR
C
12310 I=3
12320 JP=JP-3
      STACK(JP+2)=CONS(NIL,NIL)
      STACK(JP+1)=STACK(JP+2)
      STACK(JP)=I
      GOTO 12240
C
C MAP
C
12330 I=2
      GOTO 12230
C
C MAPLIST
C
12340 I=4
      GOTO 12320
C
C OPEN0
C
12345 I= OPENF(CONS(ARG,CONS(ARG2,ARG3)))
      IF(I.GT.0) IRES=MKNUM(I)
      IF(I.LE.0)IRES=NIL
      GOTO 998
C
C
C MEMB
C
12350 I=ARG
      IRES=ARG2
12360 IF (NLISTP(IRES)) GOTO 3090
      IF (I.EQ.CAR(IRES)) GOTO 998
      IRES=CDR(IRES)
      GOTO 12360
C
C MEMBER
C
12390 I=ARG
      IRES=ARG2
12400 IF (NLISTP(IRES)) GOTO 3090
      ICAR=CAR(IRES)
      IF (EQUAL(I,ICAR) .NE. NIL) GOTO 998
      IRES=CDR(IRES)
      GOTO 12400
C
C NCHARS
C
12430 IF(ARG.GT.NATOM) GOTO 12431
      IF(ARG2.EQ.NIL.AND.CAR(ARG).NE.ARRAY) GOTO 12460
12431 IRES = NCHARS(CONS(ARG,NIL),ARG2)
C12440 = RETURN ALSO FROM PACK, UNPACK, PUTINT, CONCAT
12440 CALL APOP(PRTPOS)
      DO 12450 I=1,MARG
12450 PRBUFF(I)=BUFF(I)
      GOTO 998
12460 IF (0.GT.GETPN(ARG,MAIN,JB,IPL)) GOTO 25020
      IRES = MKNUM(IPL)
      GOTO 998
C
C NCONC
C
12470 I = 0
      TEMP1 = ARG
12480 IF (NLISTP(TEMP1)) GOTO 12490
      I = TEMP1
      TEMP1 = CDR(TEMP1)
      GOTO 12480
12490 IF (I.EQ.0) GOTO 12060
C*SETC*      CALL SETCDR(I, ARG2)
       CDR(I)= ARG2 
      GOTO 998
C
C NCONC1
C
12500 ARG2=CONS(ARG2,NIL)
      GOTO 12470
C
C NEQ
C
12510 IF(ARG-ARG2) 3100, 3090, 3100
C
C NTH
12515 IF (ARG2.LE.BIGNUM) GOTO 25020
      IF (ARG2.LE.NUMADD) GOTO 12519
      N=ARG2-1
12516 IF (N.LE.NUMADD) GOTO 998
      IF (NLISTP(ARG))GOTO 998
      ARG=CDR(ARG)
      N=N-1
      GOTO 12516
C     INTERLISP GIVES (CONS NIL ARG) FOR N<=0
12519 IRES=CONS(NIL,ARG)
      GOTO 998
C
C PACK
C
12520 ARG2=NCHARS(ARG,ARG2)-NUMADD
      ARG2 = PRTPOS-1
C                                       SAVE CHT,CHR
C                                      ALSO FROM GETINT
12530 IF (ARG2.GT.0) GOTO 12535
         IRES = MATOM(0)
         GOTO 12440
12535 N1 = CHT
      N2 = CHR
      CHT = 0
      PRTPOS = 1
      IFLG2 = T
      IRES = IREAD(1)
      IFLG2 = NIL
      CHT = N1
      CHR = N2
      GOTO 12440
C
C QUOTIENT
C
12540 IF (ARG.LE.NFREET) GOTO 25020
      IF (ARG2.LE.NFREET) GOTO 25010
      IRFLAG = NIL
      R = GTREAL(ARG,I)
      S = GTREAL(ARG2,J)
      IF (R.NE.0..OR.S.NE.0.) GOTO 12545
      IF(J.EQ.0)GOTO 25010
      N=I/J
      GOTO 3110
12545 IRFLAG = T
      IF (R.EQ.0.) R = FLOAT(I)
      IF (S.EQ.0.) S = FLOAT(J)
      IF (S.EQ.0.) GOTO 25010
      R = R/S
      GOTO 3110
C
C RPLACA
C
12570 IRET=1
12580  CONTINUE 
      IF (ARG.EQ.NIL .OR. ARG.EQ.T) GOTO 25020
      IF(ARG .GT. NFREET) GOTO 25020
      IF (ARG.GT.NATOM) GOTO 12590
      IF (SPECAT(CAR(ARG))) GOTO 25020
C*SETC*12590 CALL SETCAR(ARG, ARG2)
12590  CAR(ARG)= ARG2 
      IF(IRET .EQ. 2) ARG=ARG2
      GOTO 998
C
C RPLACD
C
12600 IF (ARG.EQ.NIL) GOTO 25020
      IF(ARG .GT. NFREET) GOTO 25020
      IF (ARG.GT.NATOM) GOTO 12610
      IF (SPECAT(CAR(ARG))) GOTO 25020
C*SETC*12610 CALL SETCDR(ARG, ARG2)
12610  CDR(ARG)= ARG2 
      GOTO 998
C
C RPT
C
12620 IF (ARG.LE.BIGNUM) GOTO 25020
      CALL APUSH(ARG)
      N=ARG
      ARG=ARG2
      CALL APUSH(ARG2)
12630 IF(N .LE. NUMADD) GOTO 12650
      CALL FPUSH(22)
      GOTO 1600
C
C--R22       RETURN FROM EVAL(ARG)
C
12640 N=STACK(JP+1)-1
      STACK(JP+1)=N
      ARG=STACK(JP)
      GOTO 12630
12650 JP=JP+2
      GOTO 3090
C
C SASSOC
12655 IF (NLISTP(ARG2))GOTO 12659
      TEMP1=CAR(ARG2)
      IF41=CAR(TEMP1)
      IF( EQUAL(ARG,IF41).NE.NIL)GOTO 12658
      ARG2=CDR(ARG2)
      GOTO 12655
12658 IRES=TEMP1
      GOTO 998
12659 IRES=ARG2
      GOTO 998
C
C SET
C
12660 IRET=2
      IF(ARG .GT. NATOM) GOTO 25020
      LOCAL=ENV
      IF (LOCAL.LE.0)GOTO 12580
C                                      ! TO RPLACA
      GOTO 12675
12670 LOCAL=-JACK(LOCAL)
      IF (LOCAL.LE.0) GOTO 12580
12675 LOCALE=JILL(LOCAL)+2
      K=LOCAL
12680 K=K-1
      IF (K.LT.LOCALE) GOTO 12670
      IF (JACK(K).NE.ARG) GOTO 12680
      JILL(K)=ARG2
      IRES=ARG2
      GOTO 998
C STRALLOC
C
12690 IF (ARG.LE.NFREET) GOTO 25020
      I = GETNUM(ARG)
      IF (0.GT.GETPN(ARG2,MAIN,JB,IPL)) GOTO 25010
      IRES = MATOM(-I)
      IF (IRES.EQ.NIL .OR. I.EQ.0) GOTO 998
      CALL GETCH(PNAME,ICH,JB)
      DO 12710 J = 1,I
         CALL PUTCH(PNAME,ICH,JBP)
12710    JBP = JBP+1
      GOTO 998
C
C ASSOC
C
12715 CONTINUE
      IF (NLISTP(ARG2))GOTO 12719
      TEMP1=CAR(ARG2)
      IF (ARG.EQ.CAR(TEMP1)) GOTO 12718
      ARG2=CDR(ARG2)
      GOTO 12715
12718 IRES=TEMP1
      GOTO 998
12719 IRES=ARG2
      GOTO 998
C
C
C CHTAB
C
12720 IF(ARG .GT. NATOM) GOTO 25020
      JB = PNP(ARG)
      CALL GETCH(PNAME,ICH,JB)
      IRES=GETCHT(ICH)+NUMADD
      IF(ARG2 .EQ. NIL) GOTO 998
      N = ARG2-NUMADD
      IF (N.LT.1 .OR. N.GT.NCHTYP) GOTO 25010
      CALL SETCHT(ICH,N)
      GOTO 998
C
C IOTAB
C
12730 N1 = ARG-NUMADD
      IF (N1.LT.1 .OR. N1.GT.10) GOTO 25020
      IRES = MKNUM(IOTAB(N1))
      IF (N1.EQ.2) IRES = IRES-1
      IF(ARG2 .EQ. NIL) GOTO 998
      N = IOBUFF
      IF (N1.NE.1) GOTO 12735
      IF (ARG2.EQ.T) ARG2 = LUNINS+NUMADD
      GOTO 12740
12735 IF (N1.NE.5) GOTO 12745
      IF (ARG2.EQ.T) ARG2 = LUNUTS+NUMADD
12740 N = MAXLUN
12745 IF (N1.GE.9) N = MAXINT
      IF (ARG2.LE.NFREET) GOTO 25010
      N2 = GETNUM(ARG2)
      IF (N2.LT.1 .OR. N2.GT.N) GOTO 25010
      IOTAB(N1)=N2
      IF (N1.EQ.2)  CALL SHIFT(2)
      GOTO 998
C TAILP
12746 IF(NLISTP(ARG2)) GOTO 3090
      ARG2=CDR(ARG2)
      IF(ARG.EQ.ARG2) GOTO 998
      GOTO 12746
C
C UNPACK
C
12750 NCH=NCHARS(CONS(ARG,NIL),ARG2)
      IRES=NIL
12760 PRTPOS=PRTPOS-1
      IF(PRTPOS .EQ. 0) GOTO 12440
C                               12440 = RETURN TO NCHARS AND RESET PRBUF
      IC=PRBUFF(PRTPOS)
      ICT=GETCHT(IC)
      IF(ICT .LT. 13 .OR. ICT .GT. 22) GOTO 12770
      IRES=CONS(ICT-13+NUMADD,IRES)
      GOTO 12760
12770 ABUFF(1)=IC
      IRES=CONS(MATOM(1),IRES)
      GOTO 12760
C
C XCALL
C
12780 IF (ARG.LE.NFREET) GOTO 25020
      IRES = XCALL(GETNUM(ARG),ARG2)
      GOTO 998
C-----------------------------------------------------------------------
C             SUBR 3
C-----------------------------------------------------------------------
C
C APPLYA
C
15000 CONTINUE
      IPREV=TOPS
      TOPS=TOPS+1
      JACK(TOPS)=SFORM
      JILL(TOPS)=ARG3
15001 TEMP1=CAR(ARG3)
      IF(NLISTP(TEMP1)) GOTO 15002
      IF (TOPS.GT.HILL-60) GOTO 15001
      TOPS=TOPS+1
      ARG3=CDR(ARG3)
      JACK(TOPS)=CAR(TEMP1)
      JILL(TOPS)=CDR(TEMP1)
      GOTO 15001
15002 TOPS=TOPS+1
      JACK(TOPS)=0
      JILL(TOPS)=IPREV
      CALL APUSH(ENV)
      ENV=TOPS
      CALL FPUSH(18)
      GOTO 1500
C
C--R18    RETURN FROM APPLY
C
15010 CONTINUE
      CALL APOP(ENV)
      TOPS=JILL(TOPS)
      GOTO 998
C  APPLYSTK
15012 IPREV=TOPS
      TEMP1=GETNUM(ARG3)
      IF(ILLENV(TEMP1)) GOTO 25036
      TOPS=TOPS+1
      JACK(TOPS)=-TEMP1
      JILL(TOPS)=IPREV
      CALL APUSH(ENV)
      ENV=TOPS
      CALL FPUSH(1)
      GOTO 1500
C R-1
15013 TOPS=JILL(TOPS)
      CALL APOP(ENV)
      GOTO 998
C
C ARRAY
C
15015 I1CONS = ARG
      DO 15016 IREG = 1,3
      ARG = ARGS(IREG)
      IF (ARG.LE.NFREET) GOTO 25030
      ARGS(IREG+5) = GETNUM(ARG)
      IF (ARGS(IREG+5).LT.0) GOTO 25030
15016 CONTINUE
      TEMP1 = TEMP1-TEMP2-TEMP3
      IF (TEMP1.GE.0) GOTO 15017
      ARG = I1CONS
      GOTO 25030
15017 IRES = MATOM(-((TEMP1+3)*JBYTES + (TEMP2+1)*IBYTES
     *               + (TEMP3+1)*BYTES -3))
      IF (IRES.EQ.NIL) GOTO 998
C*SETC*      CALL SETCAR(IRES, ARRAY)
       CAR(IRES)= ARRAY 
      JBP = PNP(IRES)
      DO 15019 IREG = 1,3
15019 CALL ARRUTL(IRES,4,IREG,0,ARGS(IREG+5))
      GOTO 998
C
C PRIN0
C
15020 TEMP1=DREG(5)
      TEMP2=DREG(2)
      TEMP3=DREG(7)
      DREG(5)=ARG2
      DREG(2)=NIL
      DREG(7)=NIL
      IF (ARG3 .EQ. NIL) GOTO 15030
      DREG(2)=T
      IF (ARG3 .GT. NFREET) DREG(7)=T
15030 CALL PRIN1(ARG)
      DREG(5)=TEMP1
      DREG(2)=TEMP2
      DREG(7)=TEMP3
      GOTO 998
C
C MAPC = 12220
C
C MAPCAR = 12290
C
C
C PUT
C
15040 TEMP1 = ARG
      IF (TEMP1.EQ.NIL .OR. TEMP1.GT.NFREET) GOTO 25030
      IF (SPECAT(CAR(TEMP1))) GOTO 25030
15050 I = CDR(TEMP1)
      IF (.NOT.NLISTP(I)) GOTO 15060
C*SETC*      CALL SETCDR(TEMP1, CONS(ARG2,CONS(ARG3,NIL)))
       CDR(TEMP1)= CONS(ARG2,CONS(ARG3,NIL)) 
      GOTO 15070
15060 TEMP1 = I
      I = CDR(TEMP1)
      IF (CAR(TEMP1).NE.ARG2) GOTO 15080
C*SETC*      CALL SETCAR(I, ARG3)
       CAR(I)= ARG3 
15070 IRES = ARG3
      GOTO 998
15080 TEMP1 = I
      GOTO 15050
C
C RPLSTRING
C
15130 TEMP1 = ARG
      IF (1.NE.GETPN(ARG,MAIN,JB,IPL)) GOTO 25030
      ARG = ARG2
      IF (ARG.LE.NFREET) GOTO 25030
      I = GETNUM(ARG)
      IF (I.LE.0) GOTO 25030
      JB = JB+(I-1)
      IPL = IPL-(I-1)
      IF (IPL.LE.0) GOTO 3080
      ARG = ARG3
      IF (1.NE.GETPN(ARG,MAIN,JB2,IPL2)) GOTO 25030
C                                      NEVER RPL OUTSIDE GOAL STRING
      IF (IPL.GT.IPL2) IPL = IPL2
      IF (IPL.EQ.0) GOTO 3080
      IMAX = JB2+IPL-1
      DO 15140 I = JB2,IMAX
         CALL GETCH(PNAME,ICH,I)
         CALL PUTCH(PNAME,ICH,JB)
15140    JB = JB+1
      GOTO 3080
C
C SETA
C
15142 JNDEX = (NUMBP-1)*BYTES/JBYTES
      JPNAME(JNDEX) = ARG3
      IREG = 1
      GOTO 15148
C
C SETI
C
15144 IF (ARG3.LE.NFREET) GOTO 25026
      JNDEX = (NUMBP-1)*BYTES/IBYTES
      IPNAME(JNDEX) = GETNUM(ARG3)
      IREG = 2
      GOTO 15148
C
C SETR
C
15146 IF (ARG3.LE.NFREET) GOTO 25026
      JNDEX = NUMBP-1
      R = GTREAL(ARG3,I)
      IF (R.EQ.0.) R = I
      PNAME(JNDEX) = R
      IREG = 3
15148 IF (ARG2.LE.NFREET) GOTO 25025
      CALL ARRUTL(ARG,2,IREG,GETNUM(ARG2),JNDEX)
      IF (IBREAK) GOTO 2400
      IRES = ARG3
      GOTO 998
C
C SUBPAIR (OLD NEW S)
C
15150 IRES=SUBPR(ARG,ARG2,ARG3)
      GOTO 998
C
C SUBSTRING
C
15160 IF (1.NE.GETPN(ARG,MAIN,JB,IPL)) GOTO 25030
C                                      LOOK AT 2ND ARG
      TEMP1=ARG
      ARG = ARG2
      IF (ARG2.LE.NFREET) GOTO 25030
      ARG2 = GETNUM(ARG2)
      IF (ARG2.LE.0) ARG2 = 1+IPL +ARG2
      IF (ARG2.LT.1 .OR. ARG2.GT.1+IPL) GOTO 3090
C                                      LOOK AT 3RD ARG
      ARG = ARG3
      IF (ARG3.EQ.NIL) ARG3 = MKNUM(IPL)
      IF (ARG3.LE.NFREET) GOTO 25030
      ARG3 = GETNUM(ARG3)
      IF (ARG3.LT.0) ARG3 = 1+IPL +ARG3
      IF (ARG3.LT.ARG2-1 .OR. ARG3.GT.IPL) GOTO 3090
C                                      MAKE THE SUBSTRING
      IRES = MATOM(0)
      I=GETPN(TEMP1,MAIN,JB,IPL)
      IF (IRES.EQ.NIL) GOTO 998
C*SETC*      CALL SETCAR(IRES, SUBSTR)
       CAR(IRES)= SUBSTR 
C*SETC*      CALL SETCDR(IRES, CONS (MAIN, CONS
       CDR(IRES)= CONS (MAIN, CONS
     * (MKNUM (ARG2 + JB - PNP (MAIN)), MKNUM (1+ARG3 -ARG2))) 
C*SETC*     *)
C
      GOTO 998
C
C
C SYSERROR
C
15190 CALL MESS(ARG-NUMADD)
      CALL IPRINT(ARG2)
      CALL IPRINT(ARG3)
      GOTO 1
C-----------------------------------------------------------------------
C               SUBR N
C-----------------------------------------------------------------------
C
C CONCAT
C
16000 IFLG2 = T
      GOTO 16010
C      (FROM LIST)                     ARG NOW = ARGLIST
16005 TEMP1 = MATOM(0)
C                                      TERPRI WILL TEST OFLO
C                                      TEMP1 WILL GUARD FROM GARB
      NCH = NCHARS(ARG,NIL)
      CALL TERPRI
      IFLG2 = NIL
      IRES = TEMP1
      GOTO 12440
C
C LIST
C
16010    IRES=NIL
      IF(IARGS.EQ.0) GOTO 3300
      MAX = INDEX+IARGS-1
      DO 16020 KALLE=INDEX,MAX
      I=MAX-KALLE+INDEX
      TEMP1=JILL(I)
16020 IRES=CONS(TEMP1,IRES)
      GOTO 3300
C
C PLUS
C
16040 N=0
      IRFLAG = NIL
      IF(IARGS.EQ.0) GOTO 3105
      MAX = INDEX+IARGS-1
      DO 16060 I=INDEX,MAX
      IST=JILL(I)
      IF(IST .LE. NFREET) GOTO 25040
      S = GTREAL(IST,J)
      IF (S.NE.0..OR.IRFLAG.NE.NIL) GOTO 16044
      N = N+J
      GOTO 16060
16044 IF (IRFLAG.NE.NIL) GOTO 16046
      IRFLAG = T
      R = FLOAT(N)
16046 IF (S.EQ.0.) S = FLOAT(J)
      R = R+S
16060 CONTINUE
      GOTO 3105
C
C SYSFLAG
C
16070 IRES=NIL
      IF(IARGS.EQ.0) GOTO 3300
      N = JILL(INDEX) -NUMADD
      MAX=IARGS+INDEX-1
      IF (N.LT.1 .OR. N.GT.7) GOTO 25040
      IRES=DREG(N)
      IF(IARGS.EQ.1) GOTO 3300
      TEMP1 = JILL(INDEX+1)
      IF (TEMP1.GT.T) GOTO 25040
      DREG(N) = TEMP1
      GOTO 3300
C
C TIMES
C
16080 N=1
      IRFLAG = NIL
      IF(IARGS.EQ.0) GOTO 3105
      MAX=IARGS+INDEX-1
      DO 16090 I=INDEX,MAX
      IST=JILL(I)
      IF(IST .LE. NFREET) GOTO 25040
      S = GTREAL(IST,J)
      IF (S.NE.0..OR.IRFLAG.NE.NIL) GOTO 16084
      N = N*J
      GOTO 16090
16084 IF (IRFLAG.NE.NIL) GOTO 16086
      IRFLAG = T
      R = FLOAT(N)
16086 IF (S.EQ.0.) S = FLOAT(J)
      R = R*S
16090 CONTINUE
      GOTO 3105
C-----------------------------------------------------------------------
C             FSUBR
C             THIS IS A SEPARATE ENTRYPOINT ACCESSED DIRECTLY FROM EVAL
C               L = FSUBR, ARG2 = ARGUMENT LIST.
C-----------------------------------------------------------------------
18000 LL=L-SUBR
      FORM=ARG
      ARG=ARG2
18003 GOTO(18070,18135,2100,18010,18030,18020,18140,20060,2600,
     *     18040,18200,18050),LL
C         AND  BINDENV COND  FUNCTION GO   GO*   OR PROG PROGN
C        QUOTE SELECTQ SETQ
C
C COND = GOTO 2100
C
C FUNCTION
C
18010 ICAR=CAR(ARG)
      ICDR=CDR(ARG)
      IF(.NOT.NLISTP(ICDR))GOTO 18011
      IRES=ICAR
      GOTO 999
C                                    ! THE FUNCTION
18011 CALL APUSH(ICAR)
      ICDR=CAR(ICDR)
C                                    ! THE LIST
      IF(NLISTP(ICDR)) ICDR=NIL
c      ICDR=CAR(ICDR)   THIS LINE REMOVED   20 October 1984
      CALL APUSH(ICDR)
      ARG=ICDR
      CALL FPUSH(27)
      GOTO 2000
C R--27
C
18012 CONTINUE
      CALL APOP(ICDR)
      CALL APOP(ICAR)
      IF(ICDR.EQ.NIL)GOTO 18017
      TEMP1=CONS(NIL,NIL)
      TEMP2=TEMP1
18013 IF(NLISTP(IRES))GOTO 18015
      IF41=CAR(ICDR)
      IF42=CAR(IRES)
C*SETC*      CALL SETCDR(TEMP1,CONS(CONS(IF41,IF42),NIL))
       CDR(TEMP1)=CONS(CONS(IF41,IF42),NIL) 
      TEMP1=CDR(TEMP1)
      ICDR=CDR(ICDR)
      IRES=CDR(IRES)
      GOTO 18013
18015 TEMP2=CDR(TEMP2)
      IRES=CONS(FUNARG,CONS(ICAR,CONS(TEMP2,NIL)))
      GOTO 999
18017 IRES=CONS(FUNARG,CONS(ICAR,NIL))
      GOTO 999
C
C GO*
C
18020 IRET=2
      ARG=CAR(ARG)
      GOTO 20000
C
C GO
C
18030 ARG=CAR(ARG)
      IRET=1
      GOTO 20000
C
C QUOTE
C
18040 IRES=CAR(ARG)
      GOTO 999
C
C SETQ
C
18050 ICAR=CAR(ARG)
      CALL APUSH2(L,ICAR)
      ICDR=CDR(ARG)
      IF (NLISTP(ICDR)) ICDR = NIL
      ARG=CAR(ICDR)
      IP=IP+1
      STACK(IP)=10
C                                          ! CALL FPUSH(10)
      GOTO 1600
C
C--R10        RETURN FROM EVAL
C
18060 ARG2=IRES
      CALL APOP2(ARG,L)
      TOPS=TOPS+1
      JILL(TOPS)=TOPS-1
      GOTO 12660
C             TO SET
C
C AND
C
18069 ARG=T
      GOTO 999
18070 IF (ARG.EQ.NIL) GOTO 18069
      CALL APUSH(ARG)
      K=ARG
18090 ARG=CAR(K)
      CALL FPUSH(12)
      GOTO 1600
C
C--R12        RETURN FROM EVAL
C
18100 IF (IRES.LE.NIL) GOTO 18120
      K=STACK(JP)
      K=CDR(K)
      IF (.NOT.NLISTP(K)) GOTO 18130
18120 JP=JP+1
      GOTO 999
18130 STACK(JP)=K
      GOTO 18090
C
C BINDENV
18135 IF(NLISTP(ARG))GOTO 18139
      ARG=CAR(ARG)
      LOCAL=ENV
      IF (LOCAL.LE.0)GOTO 18139
      GOTO 18137
18136 LOCAL=-JACK(LOCAL)
      IF (LOCAL.LE.0) GOTO 18139
18137 LOCALE=JILL(LOCAL)+2
      K=LOCAL
18138 K=K-1
      IF (K.LT.LOCALE) GOTO 18136
      IF (JACK(K).NE.ARG) GOTO 18138
      TEMP1=-JACK(LOCAL)
      IRES=MKNUM(TEMP1)
      GOTO 999
18139 IRES=NUMADD
      GOTO 999
C
C
C OR
C
18140 CALL APUSH(ARG)
      K=ARG
18160 ARG=CAR(K)
      CALL FPUSH(13)
      GOTO 1600
C
C--R13        RETURN FROM EVAL
C
18170 IF (IRES.GT.NIL) GOTO 18120
      ICDR=STACK(JP)
      K=CDR(ICDR)
      IF (NLISTP(K)) GOTO 18120
      STACK(JP)=K
      GOTO 18160
C
C SELECTQ
C
18200 ARG=CAR(ARG)
      CALL APUSH(FORM)
      IP=IP+1
      STACK(IP)=15
      GOTO 1600
C
C--R15        RETURN FROM EVAL
C
18210 CALL APOP(FORM)
      ARG2=CDR(FORM)
18220 ARG2=CDR(ARG2)
      IF (CDR(ARG2) .EQ. NIL) GOTO 18280
C             TEST IF ARG EQ OR MEMB CAAR (ARG2)
C             EQ-TEST
      ICAR=CAR(ARG2)
      IF(NLISTP(ICAR)) GOTO 25080
      ICAR=CAR(ICAR)
      IF (ARG.EQ.ICAR) GOTO 18270
18240 IF (NLISTP(ICAR)) GOTO 18220
C             MEMB-TEST
      IF (ARG.EQ.CAR(ICAR)) GOTO 18270
      ICAR=CDR(ICAR)
      GOTO 18240
C             SUCCESS. SET-UP ARG AND JUMP TO EVLAST
18270 ICAR=CAR(ARG2)
      ARG=CDR(ICAR)
      GOTO 2600
C             FAILURE. SET-UP ARG AND JUMP TO EVAL
18280 ARG=CAR(ARG2)
      GOTO 1600
C-----------------------------------------------------------------------
C             PROG FEATURES
C
C PROGN = 2600 (EVLAST)
C
C GO
C
20000 I=IPP
      J=JPP
20010 IF (I.LE.0) GOTO 20050
      K = STACK(J-1)
20020 IF (NLISTP(K)) GOTO 20040
      IF(ARG .EQ. CAR(K)) GOTO 20030
      K=CDR(K)
      GOTO 20020
C               LABEL FOUND. RESET TO PROG STATUS AND
C               CONTINUE PROG LOOP.
20030 IPP=I
      JPP=J
      IP = IPP+3
      JP = JPP-2
      TOPS=STACK(IP)
      ENV=TOPS
      ARG=CDR(K)
      STACK(JP)=ARG
      GOTO 20110
C               LABEL NOT FOUND
20040 J = STACK(I+2)
      I = STACK(I+1)
      GOTO 20010
C     PROG LABEL NOT FOUND, TEST IF GO OR GO*
20050 IF (IRET .EQ. 2) GOTO 999
C              GO*, NORMAL RETURN
      ERRTYP=5
      GOTO 2400
C              GO, CALL SYSERROR
C
C PROG
C
C             PROLOGUE OF PROG
20060 IPREV=TOPS
      TOPS=TOPS+1
      JACK(TOPS)=SFORM
      JILL(TOPS)=FORM
      ICAR=CAR(ARG)
C                                     ! THATS VARLIST
      JP = JP-2
C                                     ! MAKE PLACE FOR 2 ITEMS ON STACK
      STACK(JP+1)=CDR(ARG)
C                                     ! THE PROGBODY
C
C        SPREAD ARGS ON STACK
C        ====================
C
20070 IF(ICAR .LE. NATOM) GOTO 20093
C                                     ! READY
      TEMP1=CAR(ICAR)
      IF(TEMP1 .LE. NATOM) GOTO 20090
C                                     ! SET VAR TO NIL
      TOPS=TOPS+1
      JACK(TOPS)=CAR(TEMP1)
      TEMP2=CDR(TEMP1)
      JILL(TOPS)=CAR(TEMP2)
      GOTO 20091
20090 TOPS=TOPS+1
      JACK(TOPS)=TEMP1
      JILL(TOPS)=NIL
20091 ICAR=CDR(ICAR)
      GOTO 20070
C        READY FIX BLOCK
20093 TOPS=TOPS+1
      JACK(TOPS)=-IPREV
      JILL(TOPS)=IPREV+1
C
C
C      EVAL PROGVARS
C      =============
C
20094 JILL(TOPS)=JILL(TOPS)+1
      IF (JILL(TOPS).EQ.TOPS) GOTO 20099
C                                            ! READY
      ARG=JILL(JILL(TOPS))
      CALL FPUSH(23)
      GOTO 1600
C R--23
20095 IF41=JILL(TOPS)
      JILL(IF41)=IRES
      GOTO 20094
20099 JILL(TOPS)=-JACK(TOPS)
      JACK(TOPS)=-ENV
      ENV=TOPS
C
C               ENTER PROG. NEW STACK POSITIONS ARE
C               CURRENT BODY, BODY, TOPS
C               JP            JP+1  JP+2
C
20100 ARG=STACK(JP+1)
      STACK(JP)=ARG
      STACK(IP+3) = TOPS
      STACK(IP+2) = JPP
      STACK(IP+1) = IPP
      IP = IP+3
      IPP = IP-3
      JPP = JP+2 
C               START PROG LOOP
20110 IF (NLISTP(ARG)) GOTO 20150
      ARG=CAR(ARG)
      IF (ARG.LE.NATOM) GOTO 20130
C                                           ! A LABEL
C             FPUSH(11)
      IP=IP+1
      STACK(IP)=11
      GOTO 1600
C
C--R11        RETURN FROM EVAL
C
20130 ICDR=STACK(JP)
      ARG=CDR(ICDR)
      STACK(JP)=ARG
      IF(ARG .NE. NIL) GOTO 20110
      GOTO 20170
C
C RETURN
C
20150 IF (IPP) 25130,20160,20165
20160 ERRTYP=6
      GOTO 2400
20165 CONTINUE 
      TOPS=JILL(TOPS)
20170 IP=IPP
      IF (IPP.LT.0) GOTO 25130
      JP=JPP
      TOPS= STACK(IP+3)
      JPP = STACK(IP+2)
      IPP = STACK(IP+1)
      GOTO 997
C-----------------------------------------------------------------------
C
C             RESET AND ERROR RETURNS.
C
C-----------------------------------------------------------------------
C
C             ERRORS WHICH APPLY ERROR FUNCTION
C
C SUBR1 ERRORS
C
25000 ERRTYP=7
      GOTO 2400
C
C SUBR2 ERRORS
C
25010 ARG = ARG2
25020 ERRTYP=8
      GOTO 2400
C
C SUBR3 ERRORS
C
25025 ARG = ARG2
      GOTO 25030
25026 ARG = ARG3
25030 ERRTYP = 9
      GOTO 2400
C ENVIRONMENT ERRORS
25035 ARG=ARG2
      GOTO 25037
25036 ARG=ARG3
25037 ERRTYP = 18
      GOTO 2400
C
C SUBRN ERROR ON ENTRY HERE, ARGS ARE ON THE A-STACK
C             MAX POINTS TO THE FIRST ARG,JP POINTS TO THE LAST.
C             IARGS=NR AF ARGS
C             BEFORE CALLING ERRORFUNCTION RESET ARG TO THE LIST OF ARGS
25040 ERRTYP=10
25050 ARG=NIL
      IF (IARGS.EQ.0) GOTO 2400
      DO 25070 I=MAX,INDEX,-1
25070 ARG=CONS(JILL(I),ARG)
      GOTO 2400
C
C FSUBR ERROR
C
25080 L = CAR(FORM)
      ARG = CDR(FORM)
      ERRTYP = 23
      GOTO 2400
C
C             ERRORS THAT RESTART THE SYSTEM
C
C PDL FULL
C--R16
C
25090 ERRTYP=12
      IF(MIDDL .LT. 10) GOTO 1
      MIDDL=MIDDL/2
      GOTO 2400
25095 ERRTYP=15
      HILLW=HILLW+65
      IF(HILLW.GT.HILL-20) GOTO 25096
      GOTO 2400
25096 CALL MESS(11)
      GOTO 1
C
C PDL EMPTY
C--R17
C
25100 ERRTYP=13
      FORM=NIL
      ARG=NIL
      L=LISPX
      GOTO 2400
C
C INTERNAL TROUBLE (INVALID STACK POINTER)
C
25130 CALL MESS(16)
C                                      DUMMY RETURN
      IF (.FALSE.) RETURN
      GOTO 1
      END
C
      SUBROUTINE SHOSTK
      INCLUDE 'F4COM.FOR'
      INTEGER IOTAB(10)
      EQUIVALENCE (LUNIN,IOTAB(1))
      ISAV10=IOTAB(10)
      ISAV9=IOTAB(9)
C                                             ! WE SAVE OLD PRINT LEVEL
C                                             ! AND LENGTH. WE USE 2 AND 3
C                                             ! IN THIS OUTPUT.
      IOTAB(10)=2
      IOTAB(9)=3
      K=TOPS
C
      CALL MESS(40)
      PRTPOS=6
      CALL PRIINT(ENV)
      PRTPOS=17
      CALL PRIINT(TOPS)
      CALL TERPRI
1212  IF(K.LE.0) GOTO 9999
      TEMP2=JILL(K)
      TEMP1=JACK(K)
      IF(TEMP1.LE.0)GOTO 777
      PRTPOS=1
      PRBUFF(PRTPOS)=NOCHAR
      PRTPOS=PRTPOS+1
      CALL PRIINT(K)
      PRTPOS=6
1213  CALL PRIN1(TEMP1)
      PRTPOS=PRTPOS+1
      CALL IPRINT(TEMP2)
      K=K-1
      GOTO 1212
777   IF(IBREAK)GOTO 9999
      PRTPOS=1
      PRBUFF(PRTPOS)=NOCHAR
      PRTPOS=PRTPOS+1
      CALL PRIINT(K)
      PRTPOS=6
      PRBUFF(PRTPOS)=ILBCHR
      PRTPOS=PRTPOS +1
      CALL PRIINT(TEMP1)
      PRTPOS=PRTPOS +2
      CALL PRIINT(TEMP2)
      PRBUFF(PRTPOS)=IRBCHR
      PRTPOS=PRTPOS+1
      CALL TERPRI
      K=K-1
      GOTO 1212
9999  CALL MESS(14)
      CALL TERPRI
      IOTAB(10)=ISAV10
      IOTAB(9)=ISAV9
      RETURN
      END
******DUMMY       (DUMMIES OF OS DEPENDENT ROUTINES)
C THE FOLLOWING ROUTINES ARE DUMMY DEFINITIONS OF OPERATING SYSTEM
C DEPENDENT SUBPROGRAMS.
      SUBROUTINE EJECT(LUN)
      WRITE(LUN,100)
100   FORMAT(1H1)
      RETURN
      END
      SUBROUTINE REW(LUN)
C IF YOU USE PHYSICAL FILE NAMES THIS FUNCTION MUST WORK
C TOGETHER WITH OPENF (SEE SUBFILE OPENF)
      REWIND LUN
      RETURN
      END
      FUNCTION MSLFT(I)
      MSLFT=0
      RETURN
      END
      SUBROUTINE MTIME(IT)
      DIMENSION IT(1)
C  SHOULD RETURN 5 CHARACTERS
      RETURN
      END
      SUBROUTINE MDATE(IT)
      DIMENSION IT(1)
C SHOULD RETURN 10 CHARACTERS
      RETURN
      END
      FUNCTION OPENF(X)
C-- AV TORE RISCH
C-- OPENS AN OS-FILE. RETURNS LOGICAL UNIT.
C-- IF OPENF LE 0 THEN ERROR
C-- X IS A LIST (FILENAME INPUT . BINARY)
C-- IF INPUT NE NIL   INPUT FILE (ELSE OUTPUT)
C-- IF BINARY NE NIL  BINARY FILE (ELSE ASCII)
C-- THIS FUNCTION SHOULD BE REWRITTEN IF YOUR FORTRAN DIALECT
C-- ALLOWS FOR PHYSICAL OPENING OF FILES
C-- SEE FURTHER THE FILE OPENF
      INTEGER OPENF,X
      OPENF=-1
      RETURN
      END
C
      SUBROUTINE BRSET
C-- THIS SUBROUTINE IS CALLED INITIALLY AND SHOULD SET UP TERMINAL
C-- INTERRUPTS SO THAT THE SUBROUTINE BRSERV IS CALLED WHENEVER THE
C-- USER TYPES AN INTERRUPT CHARACTER (E.G. CTRL-H ON DEC, 
C-- CTRL-C ON VAX11, BREAK ON IBM)
      RETURN
      END

      SUBROUTINE UPCASE(BUFF,L)
      INTEGER BUFF(1),L
C                           UPPERCASE THE CHARACTERS IN ABUFF
C                           NUMBER OF CHARACTERS = L
C                           FORMAT IS A1 FORMAT
      RETURN
      END
******F4COM       (COMMON BLOCK)
COMMON AND INTEGER DECLARATIONS
      COMMON /A/
     * NAREA ,JBYTES,IBYTES,BYTES ,CHDIV ,MAXINT,MAXBIG,MAXREC,NATOMP,
     * NFREEP,JBP   ,NUMBP ,NFREET,NUMADD,NPNAME,NFREEB,NATOM ,NSTACK,
     * NHTAB ,BIGNUM,ISMALL,DPNP  ,DPNAME,IPROMP,NATHSH,NBYTES,NCHTYP,
     * NBMESS,MAXMES,IRESOL,IPOWER,BIGMAX,FUZZ,
     * GARBS ,CGARBS,NGARBS,AGARBS,RMAX
      COMMON /B/
     * ARG   ,ARG2  ,ARG3  ,ALIST ,FORM  ,
     * TEMP1 ,TEMP2 ,TEMP3 ,I1CONS,I2CONS,NARGS ,
     * NIL   ,A000  ,APPLY ,EVAL  ,FNCELL,FEXPR ,FUNARG,LAMBDA,ARRAY ,
     * STRING,SUBSTR,LISPX ,NLAMBD,UNBOUN,PROG  ,QUOTE ,EXPR  ,ERROR ,
     * SFORM ,SINTER ,SUBARG,DOTAT ,T     ,
     * SUBR0 ,SUBR11,SUBR1 ,SUBR2 ,SUBR3 ,SUBR  ,FSUBR ,
     * IP    ,JP    ,IPP   ,JPP   ,MIDDL ,ABUP1 ,CHT   ,CHR   ,NUMGEN,
     * UNUSED,BRLEV ,BRFLG ,IFLG1 ,IFLG2 ,ISPLFT,IBREAK,ERRTYP,
     * IOBUFF,MAXLUN,LUNSYS,LUNINS,LUNUTS,MAXPAR,ITABWG,
     * LUNIN ,RDPOS ,LMARGR,MARGR ,LUNUT ,PRTPOS,LMARG ,MARG  ,LEVELL,
     * LEVELP,
     * DREG(7),ABUFF(160),RDBUFF(160),PRBUFF(160),BUFF(160),
     * IMESS(320),PNAME(5000),PNP(3000),
     * HTAB(4000),STACK(1500)
      COMMON /CARCDR/
     * CAR(28000),CDR(28000),CHTAB(128)
      COMMON /CHARS/
     * SPACE ,LPAR  ,RPAR  ,ILBCHR,IRBCHR,STRCHR,IQCHR ,UBR   ,DOT   ,
     * ITCHR ,IPLUS ,IMINUS,IFIG(10),ATEND ,SOFTBR,ECHAR ,NOCHAR
      COMMON /JAAN/
     * JILL(1500),JACK(1500),ENV,TOPS,HILL,HILLW
      LOGICAL IBREAK
      REAL BIGMAX,FUZZ,PNAME,RMAX
      INTEGER 
     * ENV,TOPS,IPROMP,HILL,HILLW,JILL,JACK,SINTER,SFORM,SUBARG,
     * BYTES ,CHDIV ,BIGNUM,DPNP  ,DPNAME,GARBS ,CGARBS,AGARBS,
     * ARG   ,ARG2  ,ARG3  ,ALIST ,FORM  ,TEMP1 ,TEMP2 ,TEMP3 ,
     * A000  ,APPLY ,EVAL  ,FNCELL,FEXPR ,FUNARG,ARRAY ,STRING,SUBSTR,
     * UNBOUN,PROG  ,QUOTE ,EXPR  ,ERROR ,DOTAT ,T     ,
     * SUBR0 ,SUBR11,SUBR1 ,SUBR2 ,SUBR3 ,SUBR  ,FSUBR ,
     * ABUP1 ,CHT   ,CHR   ,UNUSED,BRLEV ,BRFLG ,ERRTYP,
     * RDPOS ,PRTPOS,DREG  ,ABUFF ,RDBUFF,PRBUFF,BUFF  ,
     * SPACE ,RPAR  ,STRCHR,UBR   ,DOT   ,ATEND ,SOFTBR,ECHAR
      INTEGER*2 HTAB  ,STACK ,CAR   ,CDR   ,CHTAB ,PNP
     
COMMON AND INTEGER DECLARATIONS END



******MOD         (MODIFICATIONS FOR PROMPTING etc. ON E.G. DEC20)
      SUBROUTINE EJECT(LUN)
      WRITE(LUN,100)
100   FORMAT(1H1)
      RETURN
      END


      SUBROUTINE WRA1(LUN,LINE,I1,I2)
      INTEGER LINE(I2)
      INCLUDE 'F4COM.FOR'
C INSERTED BY TR:
      IF(LUN.EQ.LUNUTS)GOTO 1
      WRITE(LUN,100) (LINE(I),I=I1,I2)
      RETURN
1      WRITE(LUN,101)(LINE(I),I=I1,I2)
101   FORMAT(1X,160A1)
100   FORMAT(160A1)
      RETURN
      END
      SUBROUTINE RDA1(LUN,CARD,I1,I2,IEOF)
C             CALLED FROM SHIFT AND INIT2
      INTEGER CARD(I2)
      INCLUDE 'F4COM.FOR'
      COMMON /PROMPT/PROTXT(80),PROLEN
      INTEGER PROTXT,PROLEN
      IEOF=1
      IF (LUN.NE.LUNINS) GOTO 40
      IF (PRTPOS.GT.1) GOTO 20
      DO 9 I=1,PROLEN
9     WRITE (LUNUTS,10) PROTXT(I)
10    FORMAT (1X,A1,$)
      GOTO 40
20    K=PRTPOS-1
      DO 21 I=1,K
      WRITE(LUNUTS,10)PRBUFF(I)
21    PRBUFF(I)=SPACE 
      PRTPOS=1
40    CONTINUE
      READ(LUN,100,END=1) (CARD(I),I=I1,I2)
100   FORMAT(160A1)
      RETURN
1     IEOF=2
      RETURN
      END

      FUNCTION OPENF(X)
C-- AV TORE RISCH
C-- OPENS AN OS-FILE. RETURNS LOGICAL UNIT.
C-- IF OPENF LE 0 THEN ERROR
C-- X IS A LIST (FILENAME INPUT . BINARY)
C-- IF INPUT NE NIL   INPUT FILE (ELSE OUTPUT)
C-- IF BINARY NE NIL  BINARY FILE (ELSE ASCII)
      INCLUDE 'F4COM.FOR'
      INTEGER LUNMIN,LUNMAX,LUNTAB(10)
      INTEGER OPENF,X
      COMPLEX FILNAM(1),ACC,MODE
      EQUIVALENCE (FILNAM(1),ABUFF(1))
      DATA LUNMIN,LUNMAX,LUNTAB /10,19,10*0/
C-- IF NLISTP(X) THEN GOTO 3
      IF(X.LE.NATOM.OR.X.GT.NFREET)GO TO 3
      IFILE=CAR(X)
      X=CDR(X)
      IF(X.LE.NATOM.OR.X.GT.NFREET)GO TO 3
      INPUT=CAR(X)
      IBIN=CDR(X)
      IF(MPNAME(IFILE,ABUFF(1),35,IPL).LT.0)GO TO 3
1      DO 2 I=1,10
      IF(LUNTAB(I).EQ.0)GO TO 4
2     CONTINUE
3     OPENF = -1
      RETURN
4     LUNTAB(I)=1
      OPENF=LUNMIN+I-1
C-- WE USE LOGICAL UNIT LUNMIN TO LUNMAX
      ACC='SEQIN     '
      IF(INPUT.EQ.NIL) ACC='SEQOUT    '
      MODE='ASCII     '
      IF(IBIN.NE.NIL)MODE='BINARY    '
      II=OPENF
      OPEN(UNIT=II ,ACCESS=ACC,NAME=FILNAM
     X,MODE=MODE,ERR=3)
      RETURN
      ENTRY REW(LN)
      CLOSE(UNIT=LN)
      IF(LN.LT.LUNMIN.OR.LN.GT.LUNMAX)RETURN
      LUNTAB(LN-9)=0
      RETURN
      END
******DEC10       (ASSEMBLY ROUTINES FOR DEC10)
        TITLE   LISP
        EXTERN  FORTRA,RESET.
        TWOSEG
        RELOC 400000
BEGIN:  JFCL
        JSP     16,RESET.
        0
        MOVEI   1,START
        HRRM    1,120
        MOVEI   1,REE
        HRRM    1,124
        MOVEI   16,[[1]]
        JRST    FORTRA
START:  JFCL
        JSP     16,RESET.
        0
        MOVEI   16,[[2]]
        JRST    FORTRA
REE:    JFCL
        JSP     16,RESET.
        0
        MOVEI   16,[[3]]
        JRST    FORTRA
        ENTRY   GETCH
GETCH:  MOVE    2,@2(16)
        SUBI    2,1
        IDIVI   2,5
        IMULI   3,7
        MOVE    4,[POINT 7,0(2),6]
        ADDI    2,@(16)
        LSH     3,^D30
        SUB     4,3
        LDB     3,4
        MOVE    4,[ASCIZ/    /]
        LSHC    3,^D29
        MOVEM   3,@1(16)
        POPJ    17,
        ENTRY   PUTCH
PUTCH:  MOVE    2,@2(16)
        SUBI    2,1
        IDIVI   2,5
        IMULI   3,7
        MOVE    4,[POINT 7,0(2),6]
        ADDI    2,@(16)
        LSH     3,^D30
        SUB     4,3
        MOVE    3,@1(16)
        LSH     3,-^D29
        DPB     3,4
        POPJ    17,
        END     BEGIN
******DEC20       (ASSEMBLY ROUTINES FOR DEC20)
        TITLE   LISPF
        SEARCH MONSYM,MACSYM

        ENTRY   GETCH
GETCH:  MOVE    2,@2(16)
        SUBI    2,1
        IDIVI   2,5
        IMULI   3,7
        MOVE    4,[POINT 7,0(2),6]
        ADDI    2,@(16)
        LSH     3,^D30
        SUB     4,3
        LDB     3,4
        MOVE    4,[ASCIZ/    /]
        LSHC    3,^D29
        MOVEM   3,@1(16)
        POPJ    17,
        ENTRY   PUTCH
PUTCH:  MOVE    2,@2(16)
        SUBI    2,1
        IDIVI   2,5
        IMULI   3,7
        MOVE    4,[POINT 7,0(2),6]
        ADDI    2,@(16)
        LSH     3,^D30
        SUB     4,3
        MOVE    3,@1(16)
        LSH     3,-^D29
        DPB     3,4
        POPJ    17,


COMMENT !
ENTRY GETCHT
EXTERNAL CHARS
CHTAB==CHARS-^D128
GETCHT: MOVE 1,@(16)            ;GET CHARACTER
        LSH  1,^D-29            ;SHIFT IT AS TO MAKE IT A NUMBER
                                ;BETWEN 0 AND 127
        MOVE 0,CHTAB(1)         ;THE VALUES ARE IN CHTAB
        POPJ 17,


ENTRY SETCHT
SETCHT: MOVE 1,@(16)            ;THE CHARACTER
        LSH  1,^D-29
        MOVE 0,@1(16)           ; THE VALUE
        MOVEM 0,CHTAB(1)
        POPJ 17,

COMMENT END !

ENTRY MTIME
MTIME:
        movei 1,@(16)  
        hrli 1,440700  ; get a bytepointer 
        seto 2,
        movx 3,<ot%nda+ot%nsc>;no date no sec
        odtim
        popj 17,
entry mdate
mdate: 
        movei 1,@(16)  
        hrli 1,440700  ; get a bytepointer 
        seto 2,
        movx 3,<ot%ntm>;no time 
        odtim
        popj 17,

ENTRY MSLFT
MSLFT:  MOVEI 1,.FHSLF
        RUNTM
        MOVE 0,1
        POPJ 17,


        EXTERN BRSERV
        ENTRY BRSET
BRSET:
        MOVEI 1,.FHSLF  
        MOVE 2,[LEVTAB,,CHNTAB]
        SIR                     ; SPECIFY INTERUPT CHANNELS
          ERJMP BOOM
        MOVEI 1,.FHSLF          ; ENABLE THE INTERRUPTSYSTEM
        EIR
          ERJMP BOOM
        MOVEI 1,.FHSLF          ; ACTIVATE CHANNEL 0
        MOVE 2,[1B0]
        AIC
          ERJMP BOOM
        MOVE 1,[.TICCH,,0]      ; ASSIGN CTRL-H TO CHANNEL 0
        ATI
          ERJMP BOOM
        POPJ 17,


CHNTAB: 1,,BREAK                ; CHN 0 IS USED
        REPEAT ^D35,<0,,0>
LEVTAB: 1,,PCLOC                ; ONLY LEVEL 1 IS USED
        0,,0
        0,,0
PCLOC:  BLOCK 1
SAFE:   BLOCK 16
BREAK:  MOVEM 1,SAFE
        MOVEM 2,SAFE+1
        CALL BRSERV
        MOVE  2,SAFE+1
        MOVE  1, SAFE
        DEBRK


boom:   HRROI   1,[ASCIZ "JSYS error: "]
        ESOUT
        MOVEI   1,.PRIOU
        HRLOI   2,.FHSLF
        SETZ    3,
        ERSTR   
         JFCL                   ; never mind error
         JFCL                   ; don't care about this error either
        HRROI   1,[ASCIZ ", at user pc "]
        PSOUT
        MOVEI   1,.PRIOU
        HRRZ    2,(p)                   ; get pc where the JSYS failed
        SUBI    2,2                     ; this is more like it
        MOVX    3,FLD(6,NO%COL)+FLD(^D8,NO%RDX)
        NOUT                            ; print PC
        NOP
        POPJ 17,




ENTRY UPCASE
ADR:    BLOCK 1
LIM:    BLOCK 1
upcase: MOVEI 1,@(16)   ;ADRESS TO  FIRST CHAR
        MOVEM 1,ADR
        MOVE 0,@1(16)   ;GET LENGTH
        ADD 1,0
        MOVEM 1,LIM
LOOP:   MOVE 1,ADR
        CAML 1,LIM
        POPJ 17,
        HRLI 1,440700
        ILDB 0,1
        CAIle 0,"|"
        jrst more
        caige "a"
        jrst more
        subi 0,"a"-"A"
        dpb 0,1
more:   aos adr
        jrst loop


        END     
******IBM         (ASSEMBLY ROUTINES FOR IBM)
*
* ATTENTION KEY HANDLER.
*
BRSET    CSECT
         DS    0H                  CALL BRSET(HANDLER)
         USING *,15
         LTR   1,1
         BNZ   A
         LA    1,NOOP              DEFAULT HANDLER IS NO-OP.
         B     B
A        L     1,0(1)
         L     1,0(1)
B        ST    1,BRSERV            SAVE 'HANDLER
         STM   14,15,12(13)
         STAE  STAESERV            TRAP IO ERRORS
         LM    14,15,12(13)
         SPIE  SPIESERV,((1,12),(15,15)) TRAP ARITH. ETC. ERRORS
         LM    14,15,12(13)
         BNTS  BATCH               BNTS == "BRANCH ON NOT TIME SHARING"
         STAX  STAXSERV,OBUF=(OBUF,L'OBUF) TRAP ATTN KEY
         LM    14,15,12(13)
TS       LA    0,1                 TS RUN.  RETURN .TRUE.
         B     NOOP
BATCH    SLR   0,0                 BATCH RUN.  RETURN .FALSE.
NOOP     SLR   15,15
         BR    14
*
SPIESERV DS    0H                  ARITH. ERROR: CALL HANDLER(3)
         SH    15,8(15)            BUMP BASE REG
         B     *+6
         DC    AL2(*-8-BRSET)
         STM   13,1,SAVE1
         LA    1,3
         B     SERVA
*
STAESERV DS    0H                  IO ERROR: CALL HANDLER(2)
         SH    15,8(15)            BUMP BASE REG
         B     *+6
         DC    AL2(*-8-BRSET)
         STM   13,1,SAVE1
         LA    1,2
         B     SERVA
*
STAXSERV DS    0H                  ATTN KEY: CALL HANDLER(1)
         SH    15,8(15)            BUMP BASE REG
         B     *+6
         DC    AL2(*-8-BRSET)
         STM   13,1,SAVE1
         LA    1,1
         B     SERVA
*
SERVA    ST    1,CODE
         LA    1,PARL
         LA    13,SAVE2            PROVIDE A FRESH SAVE-AREA
         L     15,BRSERV
         BALR  14,15               INVOKE HANDLER
         L     13,4(13)              (PRAY HANDLER DOES NOT RECURSE)
         LM    13,1,0(13)          RESTORE REGS 0, 1, 13, 14, TOO
         SLR   15,15               RETURN CODE = 0
         BR    14
*
BRSERV   DS    F                   'HANDLER
CODE     DS    F                   1..3
PARL     DC    AL4(CODE)
SAVE1    DS    5F                  FOR REGS 0, 1, 13, 14
SAVE2    DS    F                   STANDARD SAVE AREA FOR HANDLER
         DC    AL4(SAVE1)
         DS    16F
OBUF     DC    C'Attention...'     IS PRINTED AFTER ATTN
         END
*
* MOVELONG FORTRAN-CALLABLE MVCL INSTRUCTION.
*
LISPASM[ START 0
         ENTRY MOVELONG        (SOURCE,OFFSET,DEST,OFFSET,LENGTH)
MOVELONG STM   2,6,28(13)          SAVE REGISTERS
         LM    2,6,0(1)            TAKE PARMS
         A     2,0(3)              SOURCE ADDR
         BCTR  2,0
         A     4,0(5)              DEST ADDR
         BCTR  4,0
         L     3,0(6)              LENGTH IN BYTES
         LR    5,3
         MVCL  4,2                 MOVE.
         LM    2,6,28(13)          RESTORE REGISTERS
         BR    14
*
* STOP   FAST PROGRAM QUIT
*
         ENTRY STOP
STOP     SLR   15,15                 CLEAR RETURN CODE
         SVC   3                     RETURN TO OS
         END
*
* ASM-ROUTINES GETCH, PUTCH (FOR LISP F3)
*
         ENTRY GETCH               (ARR,ICH,IND)
         USING GETCH,15
GETCH    STM   2,4,28(13)
         LM    2,4,0(1)            TAKE PARMS
         A     2,0(4)              COMPUTE ADDRESS
         BCTR  2,0
         MVC   0(1,3),0(2)         MOVE THE CHARACTER
         MVC   1(3,3),=C'   '      PAD WITH SPACES
         LM    2,4,28(13)
         BR    14
*
         ENTRY PUTCH               (ARR,ICH,IND)
         USING PUTCH,15
PUTCH    STM   2,4,28(13)
         LM    2,4,0(1)            TAKE PARMS
         A     2,0(4)              COMPUTE ADDRESS
         BCTR  2,0
         MVC   0(1,2),0(3)         MAKE THE MOVE
         LM    2,4,28(13)
         BR    14
         END
******VAXFOR
      SUBROUTINE BRSET
      BYTE NAMN(64)
      EXTERNAL IO$_SETMODE,IO$M_CTRLCAST,BRSER1
      INTEGER SYS$TRNLOG,SYS$ASSIGN,SYS$QIO,SYS$DASSGN,SYS$CANCEL
      INTEGER TID,BUF(1),NCHR,STRING(2),NAME(16),ESC,COND,READALL,
     X        ALLTERM,STATUS,POINTER
      CHARACTER*9 TTNAME/'SYS$INPUT'/
      EQUIVALENCE(NAME(1),NAMN(1))
      DATA ESC/'1B'X/
      READALL=%LOC(IO$_SETMODE) .OR. %LOC(IO$M_CTRLCAST)
      STRING(1)=63
      STRING(2)=%LOC(NAME)
      STATUS=SYS$TRNLOG(TTNAME,STRING(2),STRING,,,)
      IF(.NOT.STATUS)GOTO 99
      IF(NAMN(1).EQ.ESC) THEN
        STRING(1)=STRING(1)-4
        STRING(2)=%LOC(NAME(2))
      END IF
      STATUS=SYS$ASSIGN(STRING,TID,,)
      IF(.NOT.STATUS)GOTO 99
      STATUS=SYS$QIO(,%VAL(TID),%VAL(READALL),,,,
     X               BRSER1,TID,%VAL(3),,,)
      IF(.NOT.STATUS)GOTO 99
      RETURN
99    COND=-9876
      CALL LIB$STOP(COND)
      STOP
      END
      SUBROUTINE BRSER1(TID)
      INTEGER TID
      EXTERNAL SYS$CANCEL
      CALL BRSERV
      CALL SYS$CANCEL(%VAL(TID))
      CALL BRSET
      RETURN
      END
      SUBROUTINE PUTCH(VEC,CH,I)
      BYTE VEC(100),CH(4)
      VEC(I)=CH(1)
      RETURN
      END
      SUBROUTINE GETCH(VEC,CH,I)
      BYTE VEC(100),CH(4),ISP
      DATA ISP/1H /
      CH(1)=VEC(I)
      CH(2)=ISP
      CH(3)=ISP
      CH(4)=ISP
      RETURN
      END
      FUNCTION OPENF(X)
C-- AV TORE RISCH
C-- OPENS AN OS-FILE. RETURNS LOGICAL UNIT.
C-- IF OPENF LE 0 THEN ERROR
C-- X IS A LIST (FILENAME INPUT . BINARY)
C-- IF INPUT NE NIL   INPUT FILE (ELSE OUTPUT)
C-- IF BINARY NE NIL  BINARY FILE (ELSE ASCII)
      INCLUDE 'F4COM.FOR'
      COMMON /FILTAB/ LUNTAB(10)
      INTEGER OPENF,X
      CHARACTER*20 ACC,MODE
C-- IF NLISTP(X) THEN GOTO 3
      IF(X.LE.NATOM.OR.X.GT.NFREET)GO TO 3
      IFILE=CAR(X)
      X=CDR(X)
      IF(X.LE.NATOM.OR.X.GT.NFREET)GO TO 3
      INPUT=CAR(X)
      IBIN=CDR(X)
      IF(MPNAME(IFILE,ABUFF(1),35,IPL).LT.0)GO TO 3
1      DO 2 I=1,10
      IF(LUNTAB(I).EQ.0)GO TO 4
2     CONTINUE
3     OPENF = -1
      RETURN
4     LUNTAB(I)=1
C-- WE USE LOGICAL UNIT 10-19
      ACC='OLD '
      IF(INPUT.EQ.NIL) ACC='NEW '
      MODE='FORMATTED'
      IF(IBIN.NE.NIL)MODE='UNFORMATTED'
      OPEN(FILE=ABUFF ,CARRIAGECONTROL='LIST'
     X,FORM=MODE,STATUS=ACC,ERR=3,UNIT=9+I)
      OPENF=9+I
      RETURN
      END
      SUBROUTINE REW(LN)
      COMMON /FILTAB/ LUNTAB(10)
      CLOSE(UNIT=LN)
      IF( LN.GE.10 .AND. LN.LT.20 ) LUNTAB(LN-9)=0
      RETURN
      END
      SUBROUTINE COMAND(COM,LEN)
      BYTE COM(1),STRING(100)
      INTEGER LEN,STATUS,CHAR(2)
      DATA STRING(1) /1H$/
      CHAR(2)=%LOC(STRING)
      CHAR(1)=LEN+1
      DO 1 I=1,LEN
1     STRING(I+1)=COM(I)
      STATUS=LIB$SPAWN(CHAR)
      TYPE *,' Back to Lispf4'
      RETURN
      END
      INTEGER FUNCTION XCALL(FN,L)
      INCLUDE 'F4COM.FOR'
      BYTE CBUFF(100)
      INTEGER FN,L
      LOGICAL NUMBER,LISTP
      LISTP(I)=I.GT.NATOM.AND.I.LE.NFREET
      NUMBER(I)=I.GT.NFREET
      XCALL=NIL
      IF(FN.LT.0.OR.FN.GT.1)GOTO 99
      GOTO(1),FN
C--
C--  (COMMAND "COMMAND STRING")
C--  CALL VAX COMMAND INTERPRETER
C--  IMPLEMENTED BY (XCALL 1 "COMMAND STRING")
C--
1     IF(MPNAME(L,CBUFF,100,IPL).NE.0)GOTO 99
      CALL COMAND(CBUFF,IPL)
      RETURN
99    XCALL=NIL
      RETURN
      END
******VAXLSP
(FILEHEADER VAX)
(DEFINEQ
(SOPENF
  <LAMBDA (FILE IO EXT MODE)
          (PROG NIL
                (SETQ IO (SELECTQ IO (I T) (O NIL) (RETURN)))
                (SETQ MODE
                      (SELECTQ MODE
                        ((NIL ASCII) NIL)
                        (BINARY T)
                        (RETURN)))
                (OR (MEMB ': (UNPACK FILE))
                    (SETQ FILE (CONCAT "SYS$DISK:" FILE)))
                <OR (MEMB '%. (UNPACK FILE))
                    (SETQ FILE (PACK (LIST FILE '%. (OR EXT 'LSP>
                (* THERE SHOULD BE A NULL SIGN BEFORE THE + ON NEXT LINE)
                (SETQ FILE (CONCAT FILE "+"))
                (RETURN (OPEN0 FILE IO MODE>)
  
(COMMAND
  (LAMBDA (X)                                       (* EXECUTE VAX OS COMMAND IN
 
                                                    THE STRING X)
          (XCALL 1 X)))
  
)
(PRINT 'VAXFNS)
(RPAQQ VAXFNS (SOPENF COMMAND))
STOP
******FLOSYS      (SYSTEM ATOMS)
 ()<>"'..T+-0123456789%^E#
(
NIL
BTV*
CLOCK
DATE
EJECT
EXIT
GENSYM
LISPX
RATOM
READ
READC
READP
RESET
TERPRI
TIME
)

(
ADD1
ERRORMESS
RECLAIM
ROLLIN
ROLLOUT
SUB1
REWIND
)

(
ALIST
ARRAYSIZE
ARRAYP
ATOM
CAR
CDR
CAAR
CADR
CDAR
CDDR
CAAAR
CAADR
CADAR
CADDR
CDAAR
CDADR
CDDAR
CDDDR
EVAL
EVLIS
FIXP
FLOATP
GETD
LAST
LENGTH
LISTP
LITATOM
NLISTP
NULL
NUMBERP
OBLIST
PROG1
PROMPTTEXT
RETURN
REVERSE
STRINGP
ZEROP
)

(
ADDLIST
ALPHORDER
APPEND
APPLY
ASSOC
CHTAB
CONS
DIFFERENCE
ELT
ELTI
ELTR
EQ
EQUAL
EVALA
EVSTK
GETP
GREATERP
IOTAB
IQUOREM
LESSP
MEMB
MEMBER
NCHARS
NCONC
NCONC1
NEQ
NTH
PACK
QUOTIENT
RPLACA
RPLACD
RPT
SASSOC
SET
STRALLOC
TAILP
UNPACK
XCALL
)

(
APPLYA
APPLYSTK
ARRAY
MAP
MAPC
MAPCAR
MAPLIST
OPEN0
PRIN0
PUT
RPLSTRING
SETA
SETI
SETR
SUBPAIR
SUBSTRING
SYSERROR
)

(
CONCAT
LIST
PLUS
SYSFLAG
TIMES
)

(
AND
BINDENV
COND
FUNCTION
GO
GO*
OR
PROG
PROGN
QUOTE
SELECTQ
SETQ
)

A000
APPLY
EVAL
FNCELL
FSUBR
FUNARG
LAMBDA
LISPF4-ARRAY
LISPF4-STRING
LISPF4-SUBSTRING
LISPX
NLAMBDA
NOBIND
PROG
QUOTE
SUBR
SYSERROR
*FORM
*INTERN
-*-
.
T
--- Unbound variable
--- Undefined function
--- Compacting GBC. Free cells =
Exit from Lisp F4
--- Undefined label
--- RETURN outside PROG
--- Illegal argument (subr1)
--- Illegal argument (subr2)
--- Illegal argument (subr3)
--- Illegal argument (subrn)
--- Fatal parameterstack overflow
--- Stack overflow
--- LISPX drop-thru
***  Bottom  ***
--- Parameter stack owerflow 15
--- Invalid stack pointer
--- Reset
--- Illegal environment 18
--- Big number GBC. Bignum space =
Lisp F4 , latest update =
--- Argument not an array
Space (cells smallnum bignums atoms) =
--- Illegal argument (fsubr)
--- Non-recursive GBC called
--- Bignum space empty. 0 returned
--- Keyboard interrupt
--- User break
--- Array index out of bounds
--- Bad substring. NIL printed
Bye
--- Faulty funarg block
--- EOF read from standard input
--- Atom space empty. NIL returned
--- Free cell space almost exhausted
--- GBC. Free cells =
--- List space empty
--- Bignum/atom space almost exhausted
--- Bignum/atom GBC. Atom space =
GBC:s (cell compacting num num/atom) =
Environment    Top
******LIBRRY      (SYSTEM FUNCTIONS IN LISP)
(MAPC '(1 2 3 4 5 6 7) '(LAMBDA(X) (SYSFLAG X T>
(IOTAB 4 80)(IOTAB 8 80)
'(FILEHEADER BASIC1)
<PUT 'PUTD 'FNCELL '(LAMBDA (FN DEF) (PUT FN 'FNCELL DEF>
<PUTD 'FILEHEADER '(NLAMBDA (A) (PRINT (LIST 'FILEHEADER A>
<PUTD 'DEFINEQ '(NLAMBDA L (MAPC L '(LAMBDA (X) (PUTD (CAR X) (CADR X>
<PUTD 'READFILE
      '(LAMBDA (UNIT LDFLG)
               (PROG (&&X (TEMP (IOTAB 1 UNIT)))
                LOOP (SELECTQ (SETQ &&X (READ))
                              (STOP (RETURN (IOTAB 1 TEMP)))
                              (EVAL &&X))
                     (GO LOOP>
(PUTD 'PRINT '(LAMBDA (A) (PRIN0 A T) (TERPRI) A))

(PROG((F(IOTAB 1)))(RPT 7 '(READFILE F T))(INUNIT T>

(FILEHEADER BASIC2)
(DEFINEQ
(ABS
  (LAMBDA (X) (TIMES X (SIGN X))))
 
(ADDPROP
  (LAMBDA (A IND S FLAG)
          <PUT A IND
               (COND ((NLISTP (GETP A IND)) (LIST S))
                     (FLAG (CONS S (GETP A IND)))
                     (T (NCONC1 (GETP A IND) S>
          IND))
 
(APPLY*
  <LAMBDA (FN . L) (APPLYSTK FN L (BINDENV FN>)
 
 
(ATTACH
  (LAMBDA (X Y)
          (RPLACD Y (CONS (CAR Y) (CDR Y)))
          (RPLACA Y X)))
 
(COPY
  (LAMBDA (X) (SUBPAIR NIL NIL X)))
 
(DEFLIST
  <LAMBDA (L PROP)
          (MAPC L
                '(LAMBDA (X) (PUT (CAR X) PROP (CADR X>)
 
(DSUBST
  (LAMBDA (NEW OLD SOURCE)
          <COND ((LISTP SOURCE)
                  <COND ((EQUAL OLD (CAR SOURCE))
                          (RPLACA SOURCE (COPY NEW)))
                        (T (DSUBST NEW OLD (CAR SOURCE>
                  (COND ((EQUAL OLD (CDR SOURCE))
                          (RPLACD SOURCE (COPY NEW)))
                        (T (DSUBST NEW OLD (CDR SOURCE>
          SOURCE))
 
 
(GCGAG
  (LAMBDA (X) (SYSFLAG 1 X)))
 
 
(MERGE
  <LAMBDA (A B COMPAREFN)
          (COND ((NLISTP B) A)
                ((NLISTP A) B)
                (T (ATTACH NIL B)
                   (MERGE---
                     (ATTACH NIL A)
                     (CDR A)
                     (CDR B)
                     (SELECTQ COMPAREFN
                       ((T NIL) 'ALPHORDER)
                       COMPAREFN))
                   (RPLACD (RPLACA A (CADR A)) (CDDR A))
                   (RPLACD (RPLACA B (CAR A)) (CDR A>)
 
(MERGE---
  (LAMBDA (MERGEROOT A B COMPAREFN)
          (PROG NIL
           LOOP <COND ((NLISTP A)
                        (RETURN (RPLACD MERGEROOT B)))
                      ((NLISTP B)
                        (RETURN (RPLACD MERGEROOT A)))
                      <(APPLY* COMPAREFN (CAR A) (CAR B))
                        (SETQ A
                              (PROG1
                                (CDR A)
                                (RPLACD MERGEROOT (RPLACD A NIL>
                      (T (SETQ B
                               (PROG1
                                 (CDR B)
                                 (RPLACD MERGEROOT
                                   (RPLACD B NIL>
                (SETQ MERGEROOT (CDR MERGEROOT))
                (GO LOOP))))
 
(MINUS
  (LAMBDA (X) (DIFFERENCE 0 X)))
 
(MINUSP
  (LAMBDA (X) (LESSP X 0)))
 
(MKATOM
  (LAMBDA (X) (PACK (LIST X))))
 
(MKSTRING
  (LAMBDA (X) (CONCAT X)))
 
 
(PUTPROPS
  (NLAMBDA (X . L)
           (MAP L
                '(LAMBDA (A) (PUT X (CAR A) (CADR A)))
                'CDDR)))
 
(REMOVE
  (LAMBDA (X L L1)
          <MAPC L
                '(LAMBDA
                   (A)
                   (OR (EQUAL A X) (SETQ L1 (CONS A L1>
          (REVERSE L1)))
 
(REMPROP
  <LAMBDA (A IND)
          (PROG ((TEMP A))
           LOP  (COND ((EQ (CADR TEMP) IND)
                        (RPLACD TEMP (CDDDR TEMP))
                        (RETURN IND))
                      (TEMP (SETQ TEMP (CDDR TEMP)) (GO LOP>)
 
(RPAQ
  <NLAMBDA (A B) (RPLACA A (EVSTK B (BINDENV A>)
 
(RPAQQ
  (NLAMBDA (A B) (RPLACA A B)))
 
(RPTQ
  (NLAMBDA (N X)
        (APPLYSTK 'RPT (LIST (EVSTK N (BINDENV N)) X) (BINDENV N))))
 
(SETQQ
  <NLAMBDA L (APPLYSTK 'SET L (BINDENV L>)
 
(SIGN
  (LAMBDA (X)
          (COND ((ZEROP X) 0)
                ((LESSP 0 X) 1)
                (T -1))))
 
(SORT
  (LAMBDA (DATA COMPAREFN)
          (PROG ((SORTTMP1 DATA) (SORTTMP2 (CONS)))
           L2   (COND ((LISTP SORTTMP1)
                        <SETQ SORTTMP1
                              (CDR (RPLACA SORTTMP1
                                     (LIST (CAR SORTTMP1>
                        (GO L2))
                      ((NLISTP DATA) (RETURN DATA))
                      ((EQ COMPAREFN T)
                        (SETQ COMPAREFN 'ALPHORDER))
                      ((NULL COMPAREFN)
                        (SETQ COMPAREFN 'ALPHORDER)))
           L1   (COND <(NLISTP (CDR DATA))
                        (RETURN
                          (RPLACA
                            (RPLACD DATA (CDAR DATA))
                            (CAAR DATA>
                      (T (SETQ SORTTMP1 DATA)))
           LOOP (AND (LISTP SORTTMP1)
                     (LISTP (CDR SORTTMP1))
                     (PROGN (MERGE--- SORTTMP2
                              (CAR SORTTMP1)
                              (CADR SORTTMP1)
                              COMPAREFN)
                            <RPLACD SORTTMP1
                              (SETQ SORTTMP1
                                    (CDDR
                                      (RPLACA SORTTMP1
                                        (CDR SORTTMP2>
                            (GO LOOP)))
                (GO L1))))
 
(STREQUAL
  (LAMBDA (X Y)
          (AND (STRINGP X) (STRINGP Y) (EQUAL X Y))))
 
(SUBST
  (LAMBDA (X Y S)
          (SUBPAIR (CONS Y)(CONS X)S)))

(SUBLIS 
  (LAMBDA (A S)
          (SUBPAIR (MAPCAR A 'CAR)(MAPCAR A 'CDR) S)))
)
(PRINT 'BASIC2FNS)
(RPAQQ BASIC2FNS
       (ABS ADDPROP APPLY* ARRAY  ATTACH COPY DEFLIST DSUBST 
             GCGAG MERGE MERGE--- MINUS MINUSP MKATOM
            MKSTRING  PUTPROPS REMOVE REMPROP RPAQ RPAQQ RPTQ SETQQ
            SIGN SORT STREQUAL   SUBST SUBLIS))
STOP
(FILEHEADER IO1)
(DEFINEQ
(COM-READ
  <NLAMBDA (COMS-- CH)
           (PROG ((COMS (EVAL COMS--)))
                 (COND ((NULL COMS)
                         (SETQ CH (PROMPTTEXT CH))
                         (SETQ COMS (READ))
                         (PROMPTTEXT CH)
                         (RETURN COMS))
                       (T (SET COMS-- (CDR COMS))
                          (RETURN (CAR COMS>)
 
(INUNIT
  (LAMBDA (N) (IOTAB 1 N)))
 
(OUTUNIT
  (LAMBDA (N) (IOTAB 5 N)))
 
(PRINT
  (LAMBDA (X) (PRIN0 X T) (TERPRI) X))
 
(PRINTDEF
  (LAMBDA (X) (PRIN0 X T T) NIL))
 
(PRINTL
  (LAMBDA L (MAPC L 'PRIN1) (TERPRI)))
 
(PRINTLENGTH
  (LAMBDA (N) (IOTAB 9 N)))
 
(PRINTLEVEL
  (LAMBDA (N) (IOTAB 10 N)))
 
(PRINTL-SP
  (LAMBDA L
          (MAPC L '(LAMBDA (X) (PRIN1 X) (SPACES 1)))
          (TERPRI)))
(PRIN2L-SP
  (LAMBDA L
          (MAPC L '(LAMBDA (X) (PRIN2 X) (SPACES 1)))
          (TERPRI)))
 
(PRINTPOS
  (LAMBDA (N) (IOTAB 6 N)))
 
(PRIN1
  (LAMBDA (X) (PRIN0 X)))
 
(PRIN2
  (LAMBDA (X) (PRIN0 X T)))
 
 
(READPOS
  (LAMBDA (N) (IOTAB 2 N)))
 
(SPACES
  <LAMBDA (N) (IOTAB 6 (PLUS N (IOTAB 6>)
 
(*
  (FSUBR . QUOTE))
 
)
(PRINT 'IO1FNS)
(RPAQQ IO1FNS
       (COM-READ INUNIT OUTUNIT PRINT PRINTDEF PRINTL PRINTLENGTH
         PRINTLEVEL PRINTL-SP PRIN2L-SP PRINTPOS PRIN1 PRIN2  READPOS
         SPACES *))
STOP
(FILEHEADER FUNC1)
(DEFINEQ
(DE
  (NLAMBDA L
           (PUTD (CAR L) (CONS 'LAMBDA (CDR L)))
           (CAR L)))
 
(DF
  (NLAMBDA L
           (PUTD (CAR L) (CONS 'NLAMBDA (CDR L)))
           (CAR L)))
 
(GETD
  (LAMBDA (FN) (AND (NULL LDFLG) ((SUBR . GETD) FN))))
 
(SAVEDEF
  (LAMBDA (X) (PUT X 'EXPR (GETD X)) 'EXPR))
 
(UNSAVEDEF
  <LAMBDA (X)
          (AND (GETP X 'EXPR) (PUT X 'FNCELL (GETP X 'EXPR>)
 
(VIRGINFN
  (LAMBDA (X) (OR (GETP X 'VIRGINFN) ((SUBR . GETD) X))))
 
)
(PRINT 'FUNC1FNS)
(RPAQQ FUNC1FNS (DE DF GETD SAVEDEF UNSAVEDEF VIRGINFN))
(PRINT 'FUNC1VARS)
<RPAQQ FUNC1VARS
       ((P (RPAQ CURFNS)
           (RPAQ CURFILEFNS 'CURFNS)
           (RPAQ LDFLG)
>
(RPAQ CURFNS)
(RPAQ CURFILEFNS 'CURFNS)
(RPAQ LDFLG)
STOP
(FILEHEADER DEBUG1)
(DEFINEQ
(BREAK-BT
  (LAMBDA (AL BTV)
          (PRINTLEVEL
            (PRINTLEVEL *PRINTLEVEL)
            (MAPC (BREAK-SKIP1 (ALIST T)) 'BT-PRINT 'BREAK-SKIP))))
  
(BREAK-EVAL
  <LAMBDA (BREAK-FORM)
          (PROG ((*BRKFLG NIL) BREAK-EVAL)
                (RETURN (COND (*BRKEVAL !VALUE)
                              ((OR (NLISTP BREAK-FORM)
                                   (CAR BREAK-FORM))
                                (EVAL BREAK-FORM))
                              ((APPLY (CADR BREAK-FORM)
                                      (CDDR BREAK-FORM>)
  
(BREAK-SKIP
  <LAMBDA (X)
          (PROG NIL
           LOOP (RETURN (AND X
                             (SELECTQ
                               (CAADR X)
                               (BREAK-EVAL (BREAK-SKIP1 X))
                               (*FORM (CDR X))
                               (COND (BTV (CDR X))
                                     (T (SETQ X (CDR X)) (GO LOOP>)
  
(BREAK-SKIP1
  <LAMBDA (X)
          (PROG NIL
           LOOP (COND ((NULL (SETQ X (CDR X))) (RETURN NIL))
                      ((EQ (CAAR X) '*FORM)
                        (SELECTQ
                          (CADAR X)
                          <(BREAK11 SYSERROR)
                            (RETURN (CONS '**BREAK** (CDR X>
                          (GO LOOP)))
                      (T (GO LOOP>)
  
(BREAK1
  (NLAMBDA L (APPLYSTK 'BREAK11 L (BINDENV L))))
  
(BREAK11
  <LAMBDA (BRKEXP BRKWHEN BRKFN BRKCOMS SYSERROR)
          ((FSUBR . COND)
            (*BRKFLG ((SUBR . EVAL) BRKEXP))
            (((FSUBR . PROG)
               ((*BR1 ((SUBR . IOTAB) 1 T))
                 (*BR2 ((SUBR . IOTAB) 5 T))
                 (*BRKFLG T))
               (RETURN (PROG (COM *BRKEVAL
                                  (*BRKFLG T)
                                  (AL (BINDENV BRKEXP))
                                  !VALUE)
                             (OR (BREAK-EVAL BRKWHEN)
                                 (RETURN (BREAK-EVAL BRKEXP)))
                             (IOTAB 2 (IOTAB 4))
                        BREAK11LOOP
                             (PRINT (LIST BRKFN 'BROKEN))
                        L    (SETQ COM (COM-READ BRKCOMS :))
                             <SELECTQ COM
                               <?= (OR SYSERROR
                                       (PRVARS1
                                         (*ARGLIST BRKFN)
                                         (PRVARS (*ARGLIST BRKFN) AL>
                               (! (GO* BREAKOUT))
                               (OK (RETURN (BREAK-EVAL BRKEXP)))
                               <GO (RETURN
                                     (PRINT
                                       (BREAK-EVAL BRKEXP)
                                       (PRIN2 BRKFN)
                                       (PRIN1 " = ">
                               <RETURN
                                 (SETQ *BRKEVAL NIL)
                                 (RETURN
                                   (BREAK-EVAL (COM-READ BRKCOMS :>
                               (EVAL (SETQ *BRKEVAL NIL)
                                     (SETQ !VALUE (BREAK-EVAL BRKEXP))
                                     (PRINTL-SP BRKFN 'EVALUATED)
                                     (SETQ *BRKEVAL T))
                               (!EVAL (SETQ BRKCOMS
                                            (APPEND
                                              '(UB EVAL BR)
                                              BRKCOMS)))
                               (!OK (SETQ BRKCOMS
                                          (APPEND '(!EVAL OK) BRKCOMS)))
                               (!GO (SETQ BRKCOMS
                                          (APPEND '(!EVAL GO) BRKCOMS)))
                               (UB (UNBREAK1 BRKFN))
                               (BR (REBREAK1 BRKFN))
                               (BT (BREAK-BT AL))
                               (BTV (BREAK-BT AL T))
                               ((LAMBDA *BRKEVAL
                                  (PRINT (BREAK-EVAL COM>
                             (GO L))
                       (IOTAB 1 *BR1)
                       (IOTAB 5 *BR2))
               BREAKOUT
               (GO* BREAK11LOOP)
               (RESET>)
  
(BT-PRINT
  <LAMBDA (X)
          (COND ((NLISTP X) (PRINT X))
                ((SELECTQ
                   (CAR X)
                   <*FORM (PRIN2L-SP
                            (CAR X)
                            (SELECTQ (CADR X) (PROG '*PROG) (CDR X>
                   (PRIN2L-SP (CAR X) '= (CDR X>)
  
(ERRORB
  (LAMBDA NIL (GO* ERRORSET) (RESET)))
  
(ERRORN
  (LAMBDA NIL (CAR (ERRORSET 'ERRTYPE))))
  
(ERRORSET
  (LAMBDA (ERRFORM ERRFLG)
          (PROG NIL
                (RETURN (LIST (EVAL ERRFORM)))
           ERRORSET
                (RETURN NIL))))
  
(KWOTE
  (LAMBDA (X) (LIST 'QUOTE X)))
  
(PRVARS
  <LAMBDA (L AL)
          (COND ((NULL L) NIL)
                ((ATOM L) (EVSTK L AL))
                (T (CONS (EVSTK (CAR L) AL) (PRVARS (CDR L) AL>)
  
(PRVARS1
  <LAMBDA (VARS VALS)
          (COND ((NULL VARS) NIL)
                ((NLISTP VARS)
                  (PRIN2L-SP VARS '= VALS))
                (T (PRIN2L-SP (CAR VARS) '= (CAR VALS))
                   (PRVARS1 (CDR VARS) (CDR VALS>)
  
(SYSERROR
  (LAMBDA (ERRTYPE FN ARG FORM *BRKFLG)
          <COND (ERRFLG (OUTUNIT
                          (OUTUNIT T)
                          (ERRORMESS ERRTYPE)
                          (PRIN2L-SP FN '- ARG>
          (GO* ERRORSET)
          (BREAK11 FORM T FN NIL T)))
  
(*ARGLIST
  (LAMBDA (X) (CADR (GETD X))))
  
)
(PRINT 'DEBUG1FNS)
(RPAQQ DEBUG1FNS
       (BREAK-BT BREAK-EVAL BREAK-SKIP BREAK-SKIP1 BREAK1 BREAK11 BT-PRINT 
         ERRORB ERRORN ERRORSET KWOTE PRVARS PRVARS1 SYSERROR *ARGLIST))
(PRINT 'DEBUG1VARS)
<RPAQQ DEBUG1VARS ((P (RPAQ *BRKFLG) (RPAQ ERRFLG T>
(RPAQ *BRKFLG)
(RPAQ ERRFLG T)
STOP
(FILEHEADER DEBUG2)
(DEFINEQ
(ADDINNAME
  <LAMBDA (F)
          (COND ((NLISTP F) F)
                ((EQ (CADR FN) 'IN)
                  (PROG (NEW (FN (CAR F)) (IFN (CADDR F)) ND)
                        (OR (GETD FN) (RETURN))
                        (SETQ NEW (INNAME FN IFN))
                        (COND ((MEMB FN (GETP IFN 'NAMESCHANGED))
                                (RETURN NEW)))
                        (SETQ ND (SUBST NEW FN (GETD IFN)))
                        (AND (EQUAL ND (GETD IFN)) (RETURN))
                        (OR (GETP IFN 'VIRGINFN)
                            (PUT IFN 'VIRGINFN (GETD IFN)))
                        (PUT IFN 'FNCELL ND)
                        (ADDPROP IFN 'NAMESCHANGED FN)
                        (PUT NEW 'FNCELL (GETD FN))
                        (PUT NEW 'ALIAS (CONS IFN FN))
                        (RETURN NEW>)
  
(ADVICE-BODY
  (LAMBDA (FN)
          (PROG ((BDY (LAMBDAEQV FN)) FORM)
                (SETQ FORM (CDDR BDY))
                <RPLACA FORM
                        (SUBST (CAR FORM)
                               'FORM
                               '(PROG (!VALUE)
                                      (PROGN)
                                      (SETQ !VALUE FORM)
                                      (PROGN)
                                      (RETURN !VALUE>
                (RETURN BDY))))
  
(ADVISE
  (LAMBDA (FN . L)
          (PROG (WHEN WHAT
                      (BR (UNBREAK1 FN))
                      <NEW (GETD (SETQ FN (ADDINNAME FN>
                      (TMP (GETP FN 'ADVISED)))
                (OR NEW (RETURN NIL))
                (OR L (RETURN NIL))
                (OR (GETP FN 'VIRGINFN) (PUT FN 'VIRGINFN NEW))
                <OR TMP (PUT FN 'ADVISED (SETQ TMP (CONS>
                <COND ((CAR TMP))
                      (T (RPLACA TMP NEW)
                         (SETQ NEW (ADVICE-BODY NEW>
                (NCONC1 TMP L)
                (SETQ WHAT (CAR (LAST L)))
                (SETQ WHEN (COND ((CDR L) (CAR L)) ('BEFORE)))
                (PUT FN 'FNCELL NEW)
                (SETQ NEW (CADDR NEW))
                (SETQ TMP
                      (SELECTQ WHEN
                        (BIND (CADR NEW))
                        (AFTER (CADDR NEW) (CAR (NTH NEW 5)))
                        (CADDR NEW)))
                (AND WHAT (NCONC1 TMP WHAT))
                (SETQ ADVISEDFNS (ADDLIST FN ADVISEDFNS))
                (RETURN FN))))
  
(BREAK
  <NLAMBDA L (MAPCAR L '(LAMBDA (FN) (BREAK0 FN T>)
  
(BREAK-BODY
  (LAMBDA (NEW)
          (PROG ((BDY (LAMBDAEQV NEW)))
                (RPLACA (CDDR BDY)
                        (LIST 'BREAK1 (CADDR BDY) BRKWHEN FN BRKCOMS))
                (RETURN BDY))))
  
(BREAK0
  (LAMBDA (FN BRKWHEN BRKCOMS)
          (SETQ FN (ADDINNAME FN))
          (PROG ((NEW (GETD FN)) (TMP (GETP FN 'BROKEN)))
                (OR NEW (RETURN NIL))
                (OR (GETP FN 'VIRGINFN) (PUT FN 'VIRGINFN NEW))
                (COND ((NULL TMP)
                        (PUT FN 'BROKEN (LIST NEW BRKWHEN BRKCOMS)))
                      ((NULL (CAR TMP)) (RPLACA TMP NEW))
                      (T (RETURN NIL)))
                (SETQ NEW (BREAK-BODY NEW))
                (PUT FN 'FNCELL NEW)
                (SETQ BROKENFNS (ADDLIST FN BROKENFNS))
                (RETURN FN))))
  
(INNAME
  (LAMBDA (F IN) (PACK (LIST F '-IN- IN))))
  
(LAMBDAEQV
  <LAMBDA (NEW)
          (SELECTQ (CAR NEW)
                   (FUNARG (LIST (CAR NEW)
                                 (LAMBDAEQV (CADR NEW))
                                 (CADDR NEW)))
                   <(LAMBDA NLAMBDA)
                     (LIST (CAR NEW)
                           (CADR NEW)
                           (COND ((CDDDR NEW)
                                   (CONS 'PROGN (CDDR NEW)))
                                 ((CADDR NEW>
                   (LIST (COND ((EQ (CAR NEW) 'SUBR) 'LAMBDA)
                               (T 'NLAMBDA))
                         'ARGS
                         (LIST 'APPLY (LIST 'QUOTE NEW) 'ARGS>)
  
(READVISE
  <NLAMBDA L
           (MAPCAR (OR L ADVISEDFNS)
                   '(LAMBDA (FN)
                            (SETQ FN (THEINNAME FN))
                            (PROG ((OLD (GETP FN 'ADVISED)))
                                  (COND ((AND OLD (NULL (CAR OLD)))
                                          (PUT FN 'ADVISED)
                                          <MAPC
                                            (CDR OLD)
                                            '(LAMBDA
                                               (ADV)
                                               (APPLY 'ADVISE
                                                 (CONS FN ADV>
                                          (RETURN FN))
                                        (T (RETURN NIL>)
  
(REBREAK
  (NLAMBDA L (MAPCAR (OR L BROKENFNS) 'REBREAK1)))
  
(REBREAK1
  <LAMBDA (FN)
          (SETQ FN (ADDINNAME FN))
          (PROG ((OLD (GETP FN 'BROKEN)))
                (COND ((AND OLD (NULL (CAR OLD)))
                        (BREAK0 FN (CADR OLD) (CADDR OLD))
                        (RETURN FN))
                      (T (RETURN NIL>)
  
(REMINNAME
  <LAMBDA (FN TEMP)
          (COND ((NLISTP FN)
                  <COND ((SETQ ALIAS (GETP FN 'ALIAS))
                          <PUT (CAR ALIAS)
                               'FNCELL
                               (SUBST (CDR ALIAS)
                                      (INNAME (CDR ALIAS) (CAR ALIAS))
                                      (GETD (CAR ALIAS>
                          (PUT (CAR ALIAS)
                               'NAMESCHANGED
                               (REMOVE
                                 (CDR ALIAS)
                                 (GETP (CAR ALIAS) 'NAMESCHANGED>
                  FN)
                ((EQ (CADR FN) 'IN)
                  (REMINNAME (INNAME (CAR FN) (CADDR FN>)
  
(THEINNAME
  <LAMBDA (X)
          (COND ((NLISTP X) X)
                ((EQ (CADR X) 'IN) (INNAME (CAR X) (CADDR X>)
  
(TRACE
  <NLAMBDA L
           (MAPCAR L
                   '(LAMBDA (FN IFN)
                            (SETQ IFN (THEINNAME FN))
                            (COND ((GETP IFN 'TRACED) NIL)
                                  (T (OR (ADVISE FN
                                           (LIST 'TRACE-PRINT
                                             (KWOTE IFN)
                                             T))
                                         (RETURN))
                                     (PUT IFN 'TRACED T)
                                     (ADVISE FN 'BIND
                                       '(*TRACEN (ADD1 *TRACEN)))
                                     (ADVISE FN 'AFTER
                                       (LIST 'TRACE-PRINT (KWOTE IFN>)
  
(TRACE-PRINT
  <LAMBDA (FN FLG)
          (AND (GREATERP *TRACEN 15) (SETQ *TRACEN -1))
          (RPTQ *TRACEN (PROGN (PRIN1 'I) (SPACES 2)))
          (PRINTLEVEL
            (PRINTLEVEL *PRINTLEVEL)
            (COND <FLG (PRIN1 "-->")
                       (SPACES 1)
                       (PRIN2 FN)
                       (SPACES 1)
                       (PRINT (PRVARS (*ARGLIST FN) (BINDENV FN>
                  (T (PRIN1 "<--")
                     (SPACES 1)
                     (PRIN2 FN)
                     (SPACES 1)
                     (PRINT !VALUE>)
  
(UNADVISE
  (NLAMBDA L (MAPCAR (OR L ADVISEDFNS) 'UNADVISE1)))
  
(UNADVISE1
  (LAMBDA (FN)
          (SETQ FN (THEINNAME FN))
          (PROG ((OLD (GETP FN 'ADVISED)) (BR (UNBREAK1 FN)))
                (OR OLD (RETURN NIL))
                (OR (CAR OLD) (RETURN NIL))
                (PUT FN 'FNCELL (CAR OLD))
                (RPLACA OLD NIL)
                (COND (BR (REBREAK1 FN)) ((REMINNAME FN)))
                (RETURN FN))))
  
(UNBREAK
  (NLAMBDA L (MAPCAR (OR L BROKENFNS) 'UNBREAK1)))
  
(UNBREAK1
  (LAMBDA (FN)
          (SETQ FN (THEINNAME FN))
          (PROG ((OLD (GETP FN 'BROKEN)))
                (OR OLD (RETURN NIL))
                (OR (CAR OLD) (RETURN NIL))
                (PUT FN 'FNCELL (CAR OLD))
                (RPLACA OLD NIL)
                (REMINNAME FN)
                (RETURN FN))))
  
(UNTRACE
  <NLAMBDA L
           (MAPCAR <OR L
                       (REMOVE NIL
                               (MAPCAR ADVISEDFNS
                                 '(LAMBDA
                                    (X)
                                    (AND (GETP X 'TRACED) X>
                   '(LAMBDA (FN) (REMPROP FN 'TRACED) (UNADVISE1 FN>)
  
(PUTD
  (LAMBDA (FN DEF)
          (COND ((GETD FN) (SAVEDEF FN) (PRIN2L-SP FN 'REDEFINED)))
          (REMPROP FN 'TRACED)
          (REMPROP FN 'VIRGINFN)
          <COND ((GETP FN 'ADVISED) (RPLACA (GETP FN 'ADVISED>
          <COND ((GETP FN 'BROKEN) (RPLACA (GETP FN 'BROKEN>
          (PUT FN 'FNCELL DEF)
          (SET CURFILEFNS (ADDLIST FN (EVAL CURFILEFNS)))
          DEF))
  
)
(PRINT 'DEBUG2FNS)
(RPAQQ DEBUG2FNS
       (ADDINNAME ADVICE-BODY ADVISE BREAK BREAK-BODY BREAK0 INNAME LAMBDAEQV 
         READVISE REBREAK REBREAK1 REMINNAME THEINNAME TRACE TRACE-PRINT 
         UNADVISE UNADVISE1 UNBREAK UNBREAK1 UNTRACE PUTD))
(PRINT 'DEBUG2VARS)
<RPAQQ DEBUG2VARS
       ((P (RPAQ BROKENFNS) (RPAQ *BRKFLG))
         (P (RPAQ ADVISEDFNS)
            (RPAQ !ADVICEFLG)
            (RPAQ *TRACEN -1)
            (RPAQ *PRINTLEVEL 3>
(RPAQ BROKENFNS)
(RPAQ *BRKFLG)
(RPAQ ADVISEDFNS)
(RPAQ !ADVICEFLG)
(RPAQ *TRACEN -1)
(RPAQ *PRINTLEVEL 3)
STOP
(FILEHEADER EDIT)
(DEFINEQ
(EDITF
  (NLAMBDA (FN . L) (EDITS (VIRGINFN FN) L) FN))
 
(EDITS
  (LAMBDA (S EDCOM)
          (PROG (CL CTLS TEMP X A B L)
                (AND (NLISTP S)
                     (PRINTL "NOT EDITABLE")
                     (RETURN NIL))
                <AND EDCOM (SETQ EDCOM (APPEND EDCOM '(OK>
           START
           B    (SETQ CL S)
                (SETQ CTLS (LIST CL))
           NEXT (SETQ L (COM-READ EDCOM *))
                (COND ((ATOM L) (GO ATOML)))
                (SETQ X (CAR L))
                (SETQ L (CDR L))
                <COND ((NUMBERP X) (GO NUMCARX))
                      ((GETP X 'DEEDITL)
                        (SETQ EDCOM
                              (APPEND
                                (APPLY
                                  (GETP X 'DEEDITL)
                                  (LIST L))
                                EDCOM))
                        (GO NEXT))
                      (T (SELECTQ X
                           (R (DSUBST (CADR L) (CAR L) CL))
                           (N (NCONC CL L))
                           <US (COND ((SETQ TEMP
                                        (COPY
                                          (GETP
                                            (CAR L)
                                            'EDITVALUE)))
                                       (SETQ EDCOM
                                         (APPEND
                                           (SUBST TEMP
                                             (CAR L)
                                             (CDR L))
                                           EDCOM)))
                                     (T (GO ILLG>
                           (MARK (PUT (CAR L) 'EDITCHAIN CTLS))
                           <@ (COND ((AND (LITATOM (CAR L))
                                          (SETQ TEMP
                                            (GETP
                                              (CAR L)
                                              'EDITCHAIN)))
                                      (SETQ CL (CAR TEMP))
                                      (SETQ CTLS TEMP))
                                    (T (GO ILLG>
                           <: (SETQ EDCOM
                                    (CONS 'UP
                                      (CONS (CONS 1 L) EDCOM>
                           <MBD (SETQ EDCOM
                                      (CONS
                                        (CONS ': (SUBST CL '* L))
                                        (CONS 1 EDCOM>
                           (XTR (SETQ EDCOM
                                      (APPEND
                                        <CONS
                                          '(MARK LISPF3-XTR)
                                          (APPEND L
                                            '(S LISPF3-XTR
                                                (@ LISPF3-XTR)
                                                (US LISPF3-XTR
                                                    (: LISPF3-XTR>
                                        EDCOM)))
                           (GO CONT>
                (GO NEXT)
           CONT (COND ((OR (NULL (NUMBERP (CAR L)))
                           (LESSP (CAR L) 1))
                        (GO ILLG)))
                (OR (SETQ TEMP (NTH CL (CAR L)))
                    (GO EMPTY))
                (SELECTQ X
                  (LO (EDIT-SMASH TEMP (CAAR TEMP) (CDAR TEMP)))
                  (LI (EDIT-SMASH TEMP
                        (CONS (CAR TEMP) (CDR TEMP))
                        NIL))
                  (RO (NCONC (CAR TEMP) (CDR TEMP))
                      (RPLACD TEMP NIL))
                  (RI (OR (NUMBERP (CADR L)) (GO ILLG))
                      (SETQ A (NTH (CAR TEMP) (CADR L)))
                      (OR (CDR A) (GO EMPTY))
                      (RPLACD TEMP
                        (NCONC (CDR A) (CDR TEMP)))
                      (RPLACD A NIL))
                  <BO (EDIT-SMASH TEMP
                        (CAAR TEMP)
                        (NCONC (CDAR TEMP) (CDR TEMP>
                  (BI <SETQ B
                            (CDR (SETQ A
                                       (COND
                                         ((NULL
                                            (NUMBERP (CADR L)))
                                           TEMP)
                                         (T (NTH CL (CADR L>
                      (RPLACD A NIL)
                      (EDIT-SMASH TEMP
                        (CONS (CAR TEMP) (CDR TEMP))
                        B))
                  (GO ILLG))
                (GO NEXT)
           NUMCARX
                <COND ((ZEROP X) (GO ILLG))
                      <(LESSP X 0)
                        (COND ((EQ X -1)
                                <SETQ L
                                      (NCONC L
                                        (CONS
                                          (CAR CL)
                                          (CDR CL>
                                (EDIT-SMASH CL (CAR L) (CDR L)))
                              (<NLISTP
                                 (SETQ A
                                       (NTH CL
                                            (MINUS (ADD1 X>
                                (GO EMPTY))
                              (T (RPLACD A (NCONC L (CDR A>
                      <(EQ X 1)
                        (COND <L (EDIT-SMASH CL
                                   (CAR L)
                                   (NCONC (CDR L) (CDR CL>
                              ((NLISTP CL) (GO EMPTY))
                              ((NLISTP (CDR CL))
                                (SETQ TEMP
                                      (LENGTH (CADR CTLS)))
                                (SETQ EDCOM
                                      (NCONC
                                        (LIST 0
                                          (SELECTQ TEMP
                                            (1 '(1 NIL))
                                            (CONS TEMP)))
                                        EDCOM)))
                              (T (EDIT-SMASH CL
                                   (CADR CL)
                                   (CDDR CL>
                      (<NLISTP (SETQ A (NTH CL (SUB1 X>
                        (GO EMPTY))
                      (T (RPLACD A
                           (COND ((CDR A) (NCONC L (CDDR A)))
                                 (T L>
                (GO NEXT)
           ATOML
                (SETQ X L)
                <COND <(NUMBERP X)
                        (COND ((ZEROP X)
                                (OR (CDR CTLS) (GO TOP))
                                (SETQ CTLS (CDR CTLS))
                                (SETQ CL (CAR CTLS)))
                              (T (AND (LESSP X 0)
                                      (SETQ X
                                        (PLUS (LENGTH CL) 1 X)))
                                 (SETQ X (NTH CL X))
                                 (OR (LISTP X) (GO EMPTY))
                                 (SETQ CL (CAR X))
                                 (SETQ CTLS (CONS CL CTLS>
                      (T (SELECTQ X
                           (P (EDIT-PRINT CL NIL 2))
                           (PP (EDIT-PRINT CL T 2))
                           (OK (RETURN S))
                           <UP (COND ((TAILP CL (CADR CTLS)))
                                     ((NULL (CDR CTLS))
                                       (GO TOP))
                                     (T (SETQ CTLS (CDR CTLS))
                                        (SETQ CL
                                          (MEMB CL (CAR CTLS)))
                                        (OR (EQ CL (CAR CTLS))
                                            (SETQ CTLS
                                              (CONS CL CTLS>
                           (E (SETQ X
                                    (EVAL (COM-READ EDCOM *)))
                              (OR EDCOM (PRINT X)))
                           <F (SETQ TEMP
                                    (EDIT-FIND
                                      (COM-READ EDCOM *)
                                      CL CTLS))
                              <COND ((NULL TEMP)
                                      (EDIT-MSG "NOT FOUND"))
                                    (T (SETQ CTLS TEMP)
                                       (SETQ CL (CAR TEMP>
                              (COND ((ATOM CL)
                                      (SETQ EDCOM
                                        (CONS 'UP EDCOM>
                           (! (GO B))
                           <NX (COND ((TAILP CL (CADR CTLS))
                                       (SETQ CL (CDR CL))
                                       (RPLACA CTLS CL))
                                     (T (SETQ CTLS (CDR CTLS))
                                        <SETQ CL
                                          (CADR
                                            (MEMB CL (CAR CTLS>
                                        (SETQ CTLS
                                          (CONS CL CTLS>
                           (? (EDIT-PRINT CL NIL 100))
                           (?? (EDIT-PRINT CL T 100))
                           <S (SETQ A (COM-READ EDCOM *))
                              (COND ((LITATOM A)
                                      (PUT A 'EDITVALUE CL))
                                    (T (GO ILLG>
                           (COND ((GETP X 'DEEDITA)
                                   (SETQ EDCOM
                                     (APPEND
                                       (EVAL (GETP X 'DEEDITA))
                                       EDCOM)))
                                 (T (GO ILLG>
                (GO NEXT)
           ILLG (EDIT-MSG "ILLEGAL COMMAND")
           TOP  (EDIT-MSG "ON TOP LEVEL")
           EMPTY
                (EDIT-MSG "LIST EMPTY"))))
 
(EDIT-FIND
  <LAMBDA (A S TRC)
          (PROG (TEMP)
                (COND ((SETQ TEMP (MEMB A (CDR S)))
                        (RETURN (CONS TEMP TRC)))
                      ((SETQ TEMP
                             (EDIT-FIND1 A
                               (COND ((EQUAL (CAR S) A)
                                       (CDR S))
                                     (S))
                               TRC))
                        (RETURN TEMP)))
           LOOP (SETQ S (CAR TRC))
                (SETQ TRC (CDR TRC))
                (COND ((NULL TRC) (RETURN))
                      ((SETQ TEMP
                             (EDIT-FIND1 A
                               (CDR (MEMB S (CAR TRC)))
                               TRC))
                        (RETURN TEMP))
                      ((GO LOOP>)
 
(EDIT-FIND1
  <LAMBDA (A S TRC)
          (PROG (RES)
           LOOP (COND ((NLISTP S) (RETURN))
                      ((EQUAL A (CAR S))
                        (RETURN (CONS (CAR S) TRC)))
                      ((SETQ RES
                             (EDIT-FIND1 A
                               (CAR S)
                               (CONS (CAR S) TRC)))
                        (RETURN RES))
                      ((SETQ S (CDR S)) (GO LOOP>)
 
(EDIT-MSG
  (LAMBDA (MSG)
          (PRINTL MSG)
          (READPOS (IOTAB 4))
          (SETQ EDCOM)
          (GO NEXT)))
 
(EDIT-PRINT
  <LAMBDA (X PP DEPTH)
          (PRINTLEVEL
            (PRINTLEVEL DEPTH)
            (COND ((TAILP CL (CADR CTLS))
                    (PRIN1 "--- ")
                    <MAPC X
                          '(LAMBDA
                             (Y)
                             (COND (PP (PRIN0 Y T 0)
                                       (TERPRI)
                                       (SPACES 4))
                                   (T (PRIN2 Y) (SPACES 1>
                    (PRINTL '%)))
                  (T (COND (PP (PRIN0 X T 0) (TERPRI))
                           (T (PRINT X>)
 
(EDIT-SMASH
  (LAMBDA (X A B) (RPLACA X A) (RPLACD X B)))
 
)
(PRINT 'EDITFNS)
(RPAQQ EDITFNS
       (EDITF EDITS EDIT-FIND EDIT-FIND1 EDIT-MSG EDIT-PRINT EDIT-SMASH)
       )
STOP
(FILEHEADER MAKEF)
(DEFINEQ
(OPENF
  <LAMBDA L
          (COND ((NUMBERP (CAR L)) (CAR L))
                (SYMBIO (APPLY 'SOPENF L))
                ((APPLY 'LOPENF L>)
  
(ROLLOUT
  <LAMBDA (FILE TEMP)
          (SETQ TEMP (OPENF FILE 'O 'ROL 'BINARY))
          (COND (TEMP ((SUBR . ROLLOUT) TEMP)) ('(NOT OPENED>)
  
(ROLLIN
  <LAMBDA (FILE TEMP)
          (SETQ TEMP (OPENF FILE 'I 'ROL 'BINARY))
          (COND (TEMP ((SUBR . ROLLIN) TEMP)) ('(NOT OPENED>)
  
(SOPENF
  <LAMBDA (FILE IO EXT MODE)
          (PROG NIL
                (SETQ IO (SELECTQ IO (I T) (O NIL) (RETURN)))
                (SETQ MODE
                      (SELECTQ MODE
                        ((NIL ASCII) NIL)
                        (BINARY T)
                        (RETURN)))
                <OR (MEMB ': (UNPACK FILE))
                    (SETQ FILE (PACK (LIST 'DSK: FILE>
                <OR (MEMB '%. (UNPACK FILE))
                    (SETQ FILE (PACK (LIST FILE '%. (OR EXT 'LSP>
                (RETURN (OPEN0 FILE IO MODE>)
  
(LOPENF
  <LAMBDA (FILE IO EXT MODE)
          (COND ((GETP FILE IO))
                (T (PROG ((I (INUNIT T)) (O (OUTUNIT T)) RD)
                    L    (PRINTL-SP "LOGIC UNIT NO FOR FILE" FILE IO MODE)
                         (COND ((NUMBERP (SETQ RD (READ)))
                                 (PUT FILE IO RD)
                                 (INUNIT I)
                                 (OUTUNIT O)
                                 (RETURN RD))
                               (T (PRINTL-SP 
                                    "ANSWER WITH NUMERIC LOGIC UNIT NUMBER")
                                  (GO L>)
  
(CLOSE
  (LAMBDA (FILE FLG)
          (AND (CLOSE-1 'FILEIN (GETP FILE 'FILEIN)) (SETQ FLG T))
          (AND (CLOSE-1 'FILEOUT (GETP FILE 'FILEOUT)) (SETQ FLG T))
          (AND FLG FILE)))
  
(CLOSE-1
  <LAMBDA (IND N)
          (COND ((NUMBERP N) (REWIND N) (REMPROP FILE IND>)
  
(CURFILE
  (NLAMBDA (FILE)
           (SETQ CURFILE FILE)
           (SETQ CURFILEFNS (PACK (LIST FILE 'FNS)))
           (SETQ FILELST (ADDLIST FILE FILELST))
           (OR (ERRORSET CURFILEFNS NIL) (SET CURFILEFNS NIL))
           FILE))
<FILEHEADER (NLAMBDA (A)(APPLY* 'CURFILE A) (PRINT (LIST 'FILEHEADER A>
  
(LOAD
  <LAMBDA (FILE LDFLG PRINTFLG)
          (PROG (<AL (SUBST LDFLG '* '((LDFLG . *> FILENR UNIT X)
                (COND ((SETQ FILENR (OPENF FILE 'I)))
                      (T (PRINTL-SP FILE "CANNOT BE OPENED FOR INPUT")
                         (RETURN)))
                (SETQ UNIT (INUNIT FILENR))
                (IOTAB 2 (IOTAB 4))
           LOOP (SELECTQ
                  (SETQ X (READ))
                  ((NIL STOP)
                    (PRINTL-SP FILE '- FILENR 'LOADED)
                    (INUNIT UNIT)
                    (REWIND FILENR)
                    (RETURN FILE))
                  (COND (PRINTFLG (PRINT (EVALA X AL)) (GO LOOP))
                        (T (EVALA X AL) (GO LOOP>)
  
(MAKEFILE
  (LAMBDA (FILE OPT)
          (PROG ((FNS (PACK (LIST FILE 'FNS)))
                  (VARS (PACK (LIST FILE 'VARS)))
                  UNIT FILENR FNSV VARSV
                  (AL (BINDENV FILE))
                  GBC DEPTH LENGTH)
                (SETQ FNSV (CAR (ERRORSET FNS NIL)))
                (SETQ VARSV (CAR (ERRORSET VARS NIL)))
                (OR FNSV VARSV
                    (PROGN (PRINTL-SP 'BOTH FNS 'AND VARS 'EMPTY)
                           (RETURN)))
                (OR (SETQ FILENR (OPENF FILE 'O))
                    (PROGN (PRINTL-SP FILE "CANNOT BE OPENED FOR OUTPUT")
                           (RETURN)))
                (SETQ UNIT (OUTUNIT FILENR))
                (SETQ GBC (SYSFLAG 1 NIL))
                (SETQ DEPTH (PRINTLEVEL 150))
                (SETQ LENGTH (PRINTLENGTH 1000))
                (MAKEF-OUT FILEHEADER FILE)
                (COND (FNSV (MAKEF-FNSX (LIST '* (LIST 'QUOTE FNSV)))
                            (MAKEF-OUT PRINT (LIST 'QUOTE FNS))
                            (MAKEF-OUT RPAQQ FNS FNSV)))
                <COND (VARSV (MAKEF-OUT PRINT (LIST 'QUOTE VARS))
                             (MAKEF-OUT RPAQQ VARS VARSV)
                             (MAPC VARSV
                                   '(LAMBDA
                                      (X)
                                      (COND ((LITATOM X)
                                              (MAKEF-VARSX (LIST X)))
                                            ((LISTP X)
                                              (SELECTQ
                                                (CAR X)
                                                (FNS (MAKEF-FNSX (CDR X)))
                                                (VARS
                                                  (MAKEF-VARSX (CDR X)))
                                                (PROP
                                                  (MAKEF-PROPX
                                                    (CADR X)
                                                    (CDDR X)
                                                    T))
                                                (IFPROP
                                                  (MAKEF-PROPX
                                                    (CADR X)
                                                    (CDDR X)))
                                                (P (MAKEF-MAPC*
                                                     (CDR X)
                                                     'PRINT))
                                                (E (OUTUNIT UNIT)
                                                   (MAKEF-MAPC*
                                                     (CDR X)
                                                     'MAKEF-EVAL)
                                                   (OUTUNIT FILENR))
                                                (PROG1
                                                  (OUTUNIT UNIT)
                                                  (PRINTL "BAD PRETTYCOM: " X)
                                                  (OUTUNIT FILENR>
                (PRINT 'STOP)
                (REWIND FILENR)
                (OUTUNIT UNIT)
                (SYSFLAG 1 GBC)
                (PRINTLEVEL DEPTH)
                (PRINTLENGTH DEPTH)
                (PRINTL-SP FILE '- FILENR)
                (RETURN FILE))))
  
(MAKEF-EVAL
  (LAMBDA (X) (CAR (APPLYSTK 'ERRORSET (LIST X) AL))))
  
(MAKEF-FNSX
  (LAMBDA (L) (PRINTL "(DEFINEQ") (PRETTYPRINT L OPT) (PRINTL ")")))
  
(MAKEF-GETPROPS
  <LAMBDA (L)
          (COND ((NLISTP L) NIL)
                ((MEMB (CAR L) SYSPROPS) (MAKEF-GETPROPS (CDDR L)))
                <(OR NIL* (CADR L))
                  (CONS (CAR L)
                        (CONS (CADR L) (MAKEF-GETPROPS (CDDR L>
                (T (MAKEF-GETPROPS (CDDR L>)
  
(MAKEF-MAPC*
  (LAMBDA (L FN)
          (SELECTQ (AND (CDR L) (NULL (CDDR L)) (CAR L))
                                                    (* (MAPC (MAKEF-EVAL (CADR L
                                                    )) FN))
                   (MAPC L FN))))
  
(MAKEF-OUT
  (NLAMBDA LL
           (PRIN0 (CONS (CAR LL) (EVLIS (CDR LL))) T OPT)
           (TERPRI)))
  
(MAKEF-PROPX
  <LAMBDA (PROPS L NIL*)
          (COND <(EQ PROPS 'ALL)
                  (MAKEF-MAPC* L
                    '(LAMBDA (X)
                             <SETQ X
                                   (CONS X (MAKEF-GETPROPS (CDR X>
                             (COND ((CDR X)
                                     (PRIN0 (CONS 'PUTPROPS X) T OPT)
                                     (TERPRI>
                ((ATOM PROPS) (MAKEF-PROPX (LIST PROPS) L NIL*))
                (T (MAPC PROPS
                         '(LAMBDA
                            (P RES)
                            <MAKEF-MAPC* L
                              '(LAMBDA
                                 (X)
                                 (AND (OR NIL* (GETP X P))
                                      (SETQ RES
                                            (CONS
                                              (LIST X (GETP X P))
                                              RES>
                            (AND RES
                                 (MAKEF-OUT DEFLIST
                                   (LIST 'QUOTE (REVERSE RES))
                                   (LIST 'QUOTE P>)
  
(MAKEF-VARSX
  <LAMBDA (L)
          (MAKEF-MAPC* L
            '(LAMBDA (X) (MAKEF-OUT RPAQQ X (MAKEF-EVAL X>)
  
(OPEN
  (LAMBDA (FILE PROP NR)
          (AND (NUMBERP NR)
               (SELECTQ PROP
                 ((I INPUT) (PUT FILE 'I NR))
                 ((O OUTPUT) (PUT FILE 'O NR))
                 (PROGN (PUT FILE 'I NR) (PUT FILE 'O NR)))
               FILE)))
  
(PP
  (NLAMBDA L (PRETTYPRINT L T)))
  
(PRETTYPRINT
  (LAMBDA (L OPT POS)
          <SETQ POS (IOTAB 7 (PLUS 2 (IOTAB 7>
          (MAKEF-MAPC* L
            '(LAMBDA (X)
                     (PRIN1 "(")
                     (PRINT X)
                     (PRIN0 (VIRGINFN X) T OPT)
                     (PRINTL ")")
                     (TERPRI)
                     (PRINTPOS POS)))
          (IOTAB 7 POS)
          L))
  
)
(PRINT 'MAKEFFNS)
(RPAQQ MAKEFFNS
       (OPENF ROLLOUT ROLLIN SOPENF LOPENF CLOSE CLOSE-1 CURFILE 
              FILEHEADER LOAD MAKEFILE 
              MAKEF-EVAL MAKEF-FNSX MAKEF-GETPROPS MAKEF-MAPC* MAKEF-OUT 
              MAKEF-PROPX MAKEF-VARSX OPEN PP PRETTYPRINT))
(PRINT 'MAKEFVARS)
<RPAQQ MAKEFVARS
       (CURFILE FILELST SYSPROPS (P (RPAQ CURFNS) (RPAQ SYMBIO>
(RPAQQ CURFILE CUR)
(RPAQQ FILELST (CUR MAKEF EDIT DEBUG2 DEBUG1 FUNC1 IO1 BASIC2))
(RPAQQ SYSPROPS
       (ADVISED BROKEN EDITCHAIN EDITVALUE EXPR FNCELL TRACED VIRGINFN))
(RPAQ CURFNS)
(RPAQ SYMBIO)
STOP
STOP
******DEBUGLOG

[PHOTO:  Recording initiated  Wed 19-Oct-83 10:23AM]

@RUN FOO.EXE.1 
?READ unit 23   DSK:FOR23.DAT.0 at 40P+1 in RDA1 (PC 231576)
?Can't OPEN file: File not found
[Enter correct file specs]
*FLOSYS.LSP
ICH= ()<>"'..T+-0123456789%^E#
RDBUFF=(                             
IT AT 190 =    2
RDBUFF=N    I    L                   
RDBUFF=B    T    V    *              
RDBUFF=C    L    O    C    K         
RDBUFF=D    A    T    E              
RDBUFF=E    J    E    C    T         
RDBUFF=E    X    I    T              
RDBUFF=G    E    N    S    Y    M    
RDBUFF=L    I    S    P    X         
RDBUFF=R    A    T    O    M         
RDBUFF=R    E    A    D              
RDBUFF=R    E    A    D    C         
RDBUFF=R    E    A    D    P         
RDBUFF=R    E    S    E    T         
RDBUFF=T    E    R    P    R    I    
RDBUFF=T    I    M    E              
RDBUFF=)                             
NATOMP =  15
PNAME NILBTV*CLOCKDATEEJECTEXIT
PNAME GENSYMLISPXRATOMREADREADC
PNAME READPRESETTERPRITIME     
PNAME                          

RDBUFF=                              
RDBUFF=(                             
IT AT 190 =    2
RDBUFF=A    D    D    1              
RDBUFF=E    R    R    O    R    M    
RDBUFF=R    E    C    L    A    I    
RDBUFF=R    O    L    L    I    N    
RDBUFF=R    O    L    L    O    U    
RDBUFF=S    U    B    1              
RDBUFF=R    E    W    I    N    D    
RDBUFF=)                             
NATOMP =  22
PNAME NILBTV*CLOCKDATEEJECTEXIT
PNAME GENSYMLISPXRATOMREADREADC
PNAME READPRESETTERPRITIMEADD1E
PNAME RRORMESSRECLAIMROLLINROLL

RDBUFF=                              
RDBUFF=(                             
IT AT 190 =    2
RDBUFF=A    L    I    S    T         
RDBUFF=A    R    R    A    Y    S    
RDBUFF=A    R    R    A    Y    P    
RDBUFF=A    T    O    M              
RDBUFF=C    A    R                   
RDBUFF=C    D    R                   
RDBUFF=C    A    A    R              
RDBUFF=C    A    D    R              
RDBUFF=C    D    A    R              
RDBUFF=C    D    D    R              
RDBUFF=C    A    A    A    R         
RDBUFF=C    A    A    D    R         
RDBUFF=C    A    D    A    R         
RDBUFF=C    A    D    D    R         
RDBUFF=C    D    A    A    R         
RDBUFF=C    D    A    D    R         
RDBUFF=C    D    D    A    R         
RDBUFF=C    D    D    D    R         
RDBUFF=E    V    A    L              
RDBUFF=E    V    L    I    S         
RDBUFF=F    I    X    P              
RDBUFF=F    L    O    A    T    P    
RDBUFF=G    E    T    D              
RDBUFF=L    A    S    T              
RDBUFF=L    E    N    G    T    H    
RDBUFF=L    I    S    T    P         
RDBUFF=L    I    T    A    T    O    
RDBUFF=N    L    I    S    T    P    
RDBUFF=N    U    L    L              
RDBUFF=N    U    M    B    E    R    
RDBUFF=O    B    L    I    S    T    
RDBUFF=P    R    O    G    1         
RDBUFF=P    R    O    M    P    T    
RDBUFF=R    E    T    U    R    N    
RDBUFF=R    E    V    E    R    S    
RDBUFF=S    T    R    I    N    G    
RDBUFF=Z    E    R    O    P         
RDBUFF=)                             
NATOMP =  59
PNAME NILBTV*CLOCKDATEEJECTEXIT
PNAME GENSYMLISPXRATOMREADREADC
PNAME READPRESETTERPRITIMEADD1E
PNAME RRORMESSRECLAIMROLLINROLL

RDBUFF=                              
RDBUFF=(                             
IT AT 190 =    2
RDBUFF=A    D    D    L    I    S    
RDBUFF=A    L    P    H    O    R    
RDBUFF=A    P    P    E    N    D    
RDBUFF=A    P    P    L    Y         
RDBUFF=A    S    S    O    C         
RDBUFF=C    H    T    A    B         
RDBUFF=C    O    N    S              
RDBUFF=D    I    F    F    E    R    
RDBUFF=E    L    T                   
RDBUFF=E    L    T    I              
RDBUFF=E    L    T    R              
RDBUFF=E    Q                        
RDBUFF=E    Q    U    A    L         
RDBUFF=E    V    A    L    A         
RDBUFF=E    V    S    T    K         
RDBUFF=G    E    T    P              
RDBUFF=G    R    E    A    T    E    
RDBUFF=I    O    T    A    B         
RDBUFF=I    Q    U    O    R    E    
RDBUFF=L    E    S    S    P         
RDBUFF=M    E    M    B              
RDBUFF=M    E    M    B    E    R    
RDBUFF=N    C    H    A    R    S    
RDBUFF=N    C    O    N    C         
RDBUFF=N    C    O    N    C    1    
RDBUFF=N    E    Q                   
RDBUFF=N    T    H                   
RDBUFF=P    A    C    K              
RDBUFF=Q    U    O    T    I    E    
RDBUFF=R    P    L    A    C    A    
RDBUFF=R    P    L    A    C    D    
RDBUFF=R    P    T                   
RDBUFF=S    A    S    S    O    C    
RDBUFF=S    E    T                   
RDBUFF=S    T    R    A    L    L    
RDBUFF=T    A    I    L    P         
RDBUFF=U    N    P    A    C    K    
RDBUFF=X    C    A    L    L         
RDBUFF=)                             
NATOMP =  97
PNAME NILBTV*CLOCKDATEEJECTEXIT
PNAME GENSYMLISPXRATOMREADREADC
PNAME READPRESETTERPRITIMEADD1E
PNAME RRORMESSRECLAIMROLLINROLL

RDBUFF=                              
RDBUFF=(                             
IT AT 190 =    2
RDBUFF=A    P    P    L    Y    A    
RDBUFF=A    P    P    L    Y    S    
RDBUFF=A    R    R    A    Y         
RDBUFF=M    A    P                   
RDBUFF=M    A    P    C              
RDBUFF=M    A    P    C    A    R    
RDBUFF=M    A    P    L    I    S    
RDBUFF=O    P    E    N    0         
RDBUFF=P    R    I    N    0         
RDBUFF=P    U    T                   
RDBUFF=R    P    L    S    T    R    
RDBUFF=S    E    T    A              
RDBUFF=S    E    T    I              
RDBUFF=S    E    T    R              
RDBUFF=S    U    B    P    A    I    
RDBUFF=S    U    B    S    T    R    
RDBUFF=S    Y    S    E    R    R    
RDBUFF=)                             
NATOMP = 114
PNAME NILBTV*CLOCKDATEEJECTEXIT
PNAME GENSYMLISPXRATOMREADREADC
PNAME READPRESETTERPRITIMEADD1E
PNAME RRORMESSRECLAIMROLLINROLL

RDBUFF=                              
RDBUFF=(                             
IT AT 190 =    2
RDBUFF=C    O    N    C    A    T    
RDBUFF=L    I    S    T              
RDBUFF=P    L    U    S              
RDBUFF=S    Y    S    F    L    A    
RDBUFF=T    I    M    E    S         
RDBUFF=)                             
NATOMP = 119
PNAME NILBTV*CLOCKDATEEJECTEXIT
PNAME GENSYMLISPXRATOMREADREADC
PNAME READPRESETTERPRITIMEADD1E
PNAME RRORMESSRECLAIMROLLINROLL

RDBUFF=                              
RDBUFF=(                             
IT AT 190 =    2
RDBUFF=A    N    D                   
RDBUFF=B    I    N    D    E    N    
RDBUFF=C    O    N    D              
RDBUFF=F    U    N    C    T    I    
RDBUFF=G    O                        
RDBUFF=G    O    *                   
RDBUFF=O    R                        
RDBUFF=P    R    O    G              
RDBUFF=P    R    O    G    N         
RDBUFF=Q    U    O    T    E         
RDBUFF=S    E    L    E    C    T    
RDBUFF=S    E    T    Q              
RDBUFF=)                             
NATOMP = 131
PNAME NILBTV*CLOCKDATEEJECTEXIT
PNAME GENSYMLISPXRATOMREADREADC
PNAME READPRESETTERPRITIMEADD1E
PNAME RRORMESSRECLAIMROLLINROLL

RDBUFF=                              
RDBUFF=A    0    0    0              
IT AT 190 =    1
RDBUFF=A    P    P    L    Y         
IT AT 190 =    1
RDBUFF=E    V    A    L              
IT AT 190 =    1
RDBUFF=F    N    C    E    L    L    
IT AT 190 =    1
RDBUFF=F    S    U    B    R         
IT AT 190 =    1
RDBUFF=F    U    N    A    R    G    
IT AT 190 =    1
RDBUFF=L    A    M    B    D    A    
IT AT 190 =    1
RDBUFF=L    I    S    P    F    4    
IT AT 190 =    1
RDBUFF=L    I    S    P    F    4    
IT AT 190 =    1
RDBUFF=L    I    S    P    F    4    
IT AT 190 =    1
RDBUFF=L    I    S    P    X         
IT AT 190 =    1
RDBUFF=N    L    A    M    B    D    
IT AT 190 =    1
RDBUFF=N    O    B    I    N    D    
IT AT 190 =    1
RDBUFF=P    R    O    G              
IT AT 190 =    1
RDBUFF=Q    U    O    T    E         
IT AT 190 =    1
RDBUFF=S    U    B    R              
IT AT 190 =    1
RDBUFF=S    Y    S    E    R    R    
IT AT 190 =    1
RDBUFF=*    F    O    R    M         
IT AT 190 =    1
RDBUFF=*    I    N    T    E    R    
IT AT 190 =    1
RDBUFF=-    *    -                   
IT AT 190 =    1
RDBUFF=.                             
IT AT 190 =    1
RDBUFF=T                             
IT AT 190 =    1
Lisp F4 , latest update =
           (83 8 22)
Space (cells smallnum bignums atoms) =  
           (24865 17179853683 2999 2853)
--- Reset 
_(IOTAB 1 55)
RDBUFF=(    I    O    T    A    B    
IT AT 190 =    2
5
 
?READ unit 55   DSK:FOR55.DAT.0 at 40P+1 in RDA1 (PC 231576)
?Can't OPEN file: File not found
[Enter correct file specs]
*LIBRRY.LSP
RDBUFF=(    M    A    P    C         
IT AT 190 =    2
IT AT 190 =    2
IT AT 190 =    2
NIL
 
RDBUFF=(    I    O    T    A    B    
IT AT 190 =    2
80
 
IT AT 190 =    2
80
 
RDBUFF='    (    F    I    L    E    
IT AT 190 =    4
IT AT 190 =    2
(FILEHEADER BASIC1)
 
RDBUFF=<    P    U    T         '    
IT AT 190 =    2
IT AT 190 =    1
IT AT 190 =    1
IT AT 190 =    2
IT AT 190 =    1
(LAMBDA (FN DEF)
        (PUT FN 'FNCELL DEF))
 


     AND HERE IT CONTINUES .....