The historical files here represents copies of earlier versions of
Reduce and PSL with (at present) the oldes ones being from the early 1980s.
They are in general unaltered from the original archives that they were
recovered from, and a consequence of that is that some have restrictive
rights messages embedded which represented their status at that time.
Tony Hearn and Martin Griss as lead copyright holders were senty an enquiry:
> Would you grant permission for me to make these public as part of the
> above-mentioned web site (which Im expecting will eventually be
> formally accessioned into the Computer History Museum digital
> repository? Thanks very much.

Tony Hearn replied:
> Fine with me.

Martin Griss replied:
> I have no objections to their release with an appropriate note, but its
> important to know that several files were written or updated by
> multiple students at Utah and by several staff at HP Laboratories; many
> of these folks have most likely retired.
>
> So, I am not sure if we need to contact them for permission. Perhaps
> they at least need to be listed as contributors. As far as I can
> tell/recall, only some of the files have copyright notices that request
> my permission for release - I assume (or intended -:) these notice on
> the "main" files apply to all subsidiary files, both hand written and
> generated.
>
> We will need certainly to add some sort of caveat/disclosure that says
> these files are provided for historical interest only, and there is no
> implied warrantee of fitness or correctness for use, nor may they be
> used for any commercial pupose..

Please note that last paragraph that these files are made availanle to
record the historical trail of the Reduce project and the contributors -
both those named within the filea and others deserve thanks and credit.

For later copies of Reduce Tony Hearn arranged that contributors completed
paperwork to confirm that they were willing to have their code distributed
as part of Reduce. For PSL at some stage control and support was organised
through HP Labs, and a modest while after Reduce became an open source
project they confirmed that they were happy for their code to be included
as part of the open source version. It is probable that the rights that they
acquired in order to be able to develop and exploit PSL means that their
release of the code covers almost all of the versions here. See the HP
disclaimer in the PSL section of the main current version of the code.

The bibliography in the file doc/manual/bibl.bib lists many of those who
contributed to Reduce.

                                                          ACN April 2020

 

The historical files here represents copies of earlier versions of
Reduce and PSL with (at present) the oldes ones being from the early 1980s.
They are in general unaltered from the original archives that they were
recovered from, and a consequence of that is that some have restrictive
rights messages embedded which represented their status at that time.
Tony Hearn and Martin Griss as lead copyright holders were senty an enquiry:
> Would you grant permission for me to make these public as part of the
> above-mentioned web site (which Im expecting will eventually be
> formally accessioned into the Computer History Museum digital
> repository? Thanks very much.

Tony Hearn replied:
> Fine with me.

Martin Griss replied:
> I have no objections to their release with an appropriate note, but its
> important to know that several files were written or updated by
> multiple students at Utah and by several staff at HP Laboratories; many
> of these folks have most likely retired.
>
> So, I am not sure if we need to contact them for permission. Perhaps
> they at least need to be listed as contributors. As far as I can
> tell/recall, only some of the files have copyright notices that request
> my permission for release - I assume (or intended -:) these notice on
> the "main" files apply to all subsidiary files, both hand written and
> generated.
>
> We will need certainly to add some sort of caveat/disclosure that says
> these files are provided for historical interest only, and there is no
> implied warrantee of fitness or correctness for use, nor may they be
> used for any commercial pupose..

Please note that last paragraph that these files are made availanle to
record the historical trail of the Reduce project and the contributors -
both those named within the filea and others deserve thanks and credit.

For later copies of Reduce Tony Hearn arranged that contributors completed
paperwork to confirm that they were willing to have their code distributed
as part of Reduce. For PSL at some stage control and support was organised
through HP Labs, and a modest while after Reduce became an open source
project they confirmed that they were happy for their code to be included
as part of the open source version. It is probable that the rights that they
acquired in order to be able to develop and exploit PSL means that their
release of the code covers almost all of the versions here. See the HP
disclaimer in the PSL section of the main current version of the code.

The bibliography in the file doc/manual/bibl.bib lists many of those who
contributed to Reduce.

                                                          ACN April 2020

 

@Device(lpt)
@style(justification yes)
@style(spacing 1)
@use(Bibliography "<griss.docs>mtlisp.bib")
@make(article)
@modify(enumerate,numbered=<@a. @,@i. >, spread 1)
@modify(appendix,numbered=<APPENDIX @A: >)
@modify(itemize,spread 1)
@modify(description,leftmargin +2.0 inch,indent -2.0 inch)
@define(up,use text,capitalized on,  break off)
@define(mac,use text, underline off,  break off)
@define(LISPmac,use text, underline alphanumerics,  break off)
@pageheading(Left  "Utah Symbolic Computation Group",
             Right "December 1981", 
             Line "Operating Note 60"
            )
@set(page=1)
@newpage()
@begin(titlepage)
@begin(titlebox)
@b(A PASCAL Based Standard LISP for the Apollo Domain)
@center[
by

M. L. Griss and R. Ottenheimer

Department of Computer Science
University of Utah
Salt Lake City, Utah 84112

@b(Preliminary  Version)

Last Revision: @value(date)]

@end(titlebox)
@begin(abstract)
This report describes an interim implementation of Standard LISP for the
Apollo DOMAIN. This LISP is based upon the Standard LISP report, and a newly
developing Portable Standard LISP.  This interim implementation is designed
to explore LISP implementations in PASCAL on the Apollo DOMAIN and similar 
machines.
The system consists of a kernel, handcoded in PASCAL, with the rest of the
system written in LISP and compiled to PASCAL.
@End(abstract)
@begin(Researchcredit)
Work supported in part by the National Science Foundation
under Grant No. MCS80-07034.
@end(Researchcredit)
@end(titlepage)
@pageheading(Left "Apollo Pascal LISP",Center "@value(date)",
             Right "@value(Page)"
            )
@set(page=1)
@newpage
@section(Introduction)
In this preliminary report, we describe an implementation of Standard LISP
in PASCAL, PASLSP. Versions of PASLSP have been run on a number of
machines, ranging from an LSI-11 based TERAK to Apollo and PERQ. This report
concentrates on the Apollo DOMAIN implementation. This report is to be read in
conjunction with the Standard LISP report@cite(Marti79); we will
highlight the differences from the functions documented in the Standard
LISP, describe the implementation strategy, and discuss future work.

PASLSP is based on a series of small and medium sized LISP interpreters
that have been developed at the University of Utah to explore LISP
implementations in higher level languages. Each of these LISP systems
consists of a small kernel handcoded in some language, with the rest of the
system written in LISP and compiled to the target language.  We have used
FORTRAN, PASCAL and assembly language as targets. The PASLSP series use
PASCAL for the kernel, and have a LISP to PASCAL compiler for the rest of
the system. 

Recent work has concentrated on reducing the size of the hand-coded kernel,
and extending the compiler to handle systems level constructs. This has
resulted in a new Portable Standard LISP, PSL, running on the DEC-20 and
VAX-11/750@cite(Benson81,Griss81). An implementation of PSL for MC68000 is
underway. The PSL system is a modern, efficient LISP, written entirely in
itself; it uses an efficient LISP to machine code compiler to produce the
kernel, and then the rest of LISP is loaded. In the future we hope to
produce a complete PSL targeted at a higher level languages, such as
PASCAL, C or ADA, and this will replace the current PASLSP.

@subsection(History of PASLSP)
The system now called PASLSP was originally developed (by M. Griss and W.
Galway), as a small LISP like kernel to support a small computer algebra
system on an LSI-11 TERAK; this was to be used as an answer analysis module
within a CAI system@cite(Brandt81), written entirely in PASCAL. It was
decided to hand-code a very small kernel, and compile additional functions
written in LISP (LISP support functions, parser and
simplifier) to PASCAL,
using a modified Portable LISP compiler@cite(griss79). This version (call
it V0) did not even have user defined functions, since space on the TERAK
was at a premium.

About June 1981, PASLSP came to the attention of a number people evaluating
Apollo's and PERQ's, and it was suggested that we enhance V0 PASLSP for
this purpose. During the space of a few days,  features taken
from the Standard LISP Report and newly developing
PSL files were added to
produce  PASLSP-V1, running on a DEC-20 and Terak. This
was a fairly complete LISP (including Catch and Throw), but lacked a few
features (OPEN, CLOSE, RDS, WRS, PROG, GO, RETURN, COMPRESS, EXPLODE,
Vectors and Strings, etc.).  V1 PASLSP was adapted to a PERQ, VAX and
Apollo by Paul Milazo of Schlumberge in the space of a few weeks (we did
not have a PERQ or Apollo at that time).

We subsequently obtained a PERQ and an Apollo, and recent work has been
aimed at producing an enhanced PASLSP for these machines, maintaining all
versions in one set of source files.  The current system, PASLSP-V2, is
produced from a single PASCAL kernel and set of LISP support files; the
machine specific features are handled by a simple Source Code
Conditionalizer, changing the definition of certain constants and data
types. Only a few features of the Standard LISP report are missing,
and there are a number of additions.

@subsection(Acknowledgement)

We would like to acknowledge the contributions and support of
Eric Benson, Dick Brandt, Will Galway,   and Paul Milazo.

@section(Features of PASLSP and relation to Standard LISP)
PASLSP as far as possible provides all the functions mentioned
in the attached Standard LISP Report (note the hand-written
comments added to this appendix); some of the functions are simply
stubs, so that a Standard LISP Test-file can be run without major
modification.

PASLSP-V2  does not implement the following features of Standard LISP:
@begin(enumeration,spread 0)
VECTORS (only a simple garbage collector is used).

String space is not garbage collected.

Integers are limited in size (INTs and FIXNUMs, no BIGNUMs).

FLOATING Point is not implemented.

IDs can not be REMOB'ed or INTERN'd.

Only 3 Input Channels and 2 Output Channels are available to OPEN,
RDS, WRS, and CLOSE. Thus file input statements can not be nested
very deeply in files.

Line, Page and Character counting (POSN, LPOSN, etc) are not implemented.
@end(enumeration)

PASLSP-V2 provides some extensions over Standard LISP:
@begin(enumerate,spread 0)
(CATCH form) and (THROW form) and the tagged versions: (TCATCH tag form)
and (TTHROW tag form) are used to implement error and errorset, 
and higher level control functions.

Implicit PROGN in COND, and LAMBDA expressions.

(WHILE pred action-1 action-2 ... action-n).

(DSKIN 'filename)
@end(enumerate)

PASLSP-V2 has not been extensively tested, and there may still be a number
of bugs. While some effort has been spent in adjusting PASLSP to the Apollo
DOMAIN, it is clear that the various heap sizes are not yet optimal. 
See appendix A for current list of functions, and appendix B for a copy
of the Standard LISP Report annotated to reflect the current status of 
PASLSP.

@section(Using PASLSP on the Apollo DOMAIN)
	Initializing the system from the floppy looks like this:
@begin(verbatim)
Create a directory (call it pl):
	crd /pl
Mount the floppy:
	mtvol f 1 /f
Copy the files of interest:
	cpt /f/pascallisp /pl

    The files copied will be: paslsp (executable file)
                              paslsp.ini (initialization file)
                              paslsp.tst (a test file)
@end(verbatim)

Run paslsp as you would any other file.  If you
get an error it is most likely because the paslsp.ini file couldn't be found.
If this happens, locate paslsp.ini and try again.  If it still hangs,
try calling Ralph Ottenheimer at (801) 355-0226 or M. Griss at (801) 581-6542.


Previously prepared files of LISP (e.g., library procedures)
can be input by
using the function "DSKIN".  For Example,
@begin(verbatim)
(DSKIN 'Paslsptst)
(DSKIN '!/p!/foo!.sl)
@end
would load the paslsp test file.  Paslsp test is adapted from an extensive
test of Standard LISP (avoiding features not yet implemented).  This is a
good excercise, try it. [Note that the filename must be given as an ID,
and that special characters should be prefaced by an "escape character",
! . This is  also the case for filenames in OPEN.]


  Paslsp is "case-sensitive" with regard to identifiers.  All of the
kernel procedures have upper-case identifiers associated with them.  This
means that ordinarily the expression (dskin 'paslsptst) would not be
recognized since "dskin" is in lowercase.  However, there is a global flag
!*RAISE which if true will convert all lower-case typin to upper-case.
This Apollo DOMAIN paslsp implementation sets !*RAISE to T as a default by
having (SETQ !*RAISE T) in the paslsp.ini file.  You may put any special
initialization code you like at the end of paslsp.ini as indicated by the
comments in the file.
Toggling would be accomplished by typing the following lisp-expressions:
@begin(verbatim)
	(SETQ !*RAISE T)
	(SETQ !*RAISE NIL)
@end(verbatim)

	Any Apollo DOMAIN filename (25 characters maximum)is allowable
 as a paslsp filename.
Remember to prefix all special characters with an exclamation-mark: "!". 
Special characters include all non-alphanumerics. For example: fof!.ksjd
!*RAISE goforit!! paslsp!.test .
@section(Implementation of PASLSP)
@subsection(Building PASLSP)
PASLSP is built in the following steps:

@u(Kernel files), PAS0.PRE, and trailer file (main program) PASN.PRE
are run through a filter program to produce PAS0.PAS and PASN.PAS,
tailored to the Apollo DOMAIN (appropriate Include files, Consts, etc).
This kernel provides the Basic I/O (Token reading and printing),
handcoded storage allocator and garbage collector, lowlevel arithmetic
primitives, lowlevel calls (via Case statement) from LISP to kernel, etc.

@u(Rest of LISP), currently files PAS1.RED, PAS2.RED and PAS3.RED are
compiled to PASCAL using a version of the Portable LISP Compiler
(PLC)@cite(griss79). During compilation, a Symbol Table file, PASn.SYM is
read in and written out. These files record (for "incremental" compilation)
the names and ID table locations of each ID encountered, so that the compiler
can refer to an ID by its offset in the ID table. LISP constants are also
recorded in the PASn.SYM files. PAS0.SYM is modified by hand as the kernel
is changed.  

The compilation model used is that of a Register Machine: Arguments to LISP
functions are passed in registers (a PASCAL array), and the result returned
in Register 1. Space is allocated on a software stack (not the PASCAL
recursion stack), for any temporaries or save arguments required. Short
functions usually do not require any stack. The reason for this choice was
the existence of the PLC (targeted at comventional machines), and the fact
that inline access to the register array compiles quite well, while a
"PUSH/POP" stack would be much less efficient.

@u(Initialization). 
After the PAS0.PAS,..PASN.PAS are produced,
the symbol table file (pas3.sym) is converted into a file
PASLSP.INI, which contains the names of all ID's, the LISP constants
used, and also ID's for all kernel functions that should be known to the
user LISP level. Also produced is a file, EXEC.PAS, that contains a case
statement associating each user callable kernel function with an integer.
The PAS0.PAS ... PASN.PAS and EXEC.PAS are compiled and linked into an
executable .RUN file. When this file is executed, PASLSP.INI is read in:
each id is read and stored in the appropriate location in the symbol-table,
the kernal function names have the associated Case index put into
a function cell, and the LISP s-expressions are READ in. Finally,
some s-expressions will be executed (with care, the user can add his own
expressions, including requests to (DSKIN 'library), etc.
@subsection(Internal data structures)
[To be written, see the PAS0.PRE files regarding data-types,
function calling conventions, etc]
      itemref = RECORD
                tag: integer;  (* Small integer denoting the type.   *)
                info: integer; (* Either the item or a pointer to it *)
                               (* depending upon the type.           *)
                END;

      pair = PACKED RECORD
                      prcar: itemref;
                      prcdr: itemref;
                  END;

    ident = PACKED RECORD           (* identifier *)
                       idname: stringp;
                       val: itemref;       (* value *)
                       plist: itemref;     (* property list *)
                       funcell: itemref;   (* function cell *)
                       idhlink: id_ptr;    (* hash link *)
                   END;

@subsection(Adding user functions to the kernel)
[To be written, describe format of EXEC.PAS, PASLSP.INI and major functions
that are needed to add new Arithmetic extensions,
or more complex operations].

@Section(Future work on PASLSP)
PASLSP V2 is based on a fairly old model of a portable LISP, and
has been used mainly to explore the capbilities of PASCAL as a
target language. In particular, V2 PASCAL is not yet powerful enough to
run the PLC compiler  itself;
instead, the PLC is run on our PSL system on the DEC-20. In order for the
full benefits of PASLSP (or PSL) to be realized, the user should be able to
compile his own LISP modules into PASCAL and link them with the kernel.
In order to make the system even more adapatable, we would like to write
even less of the kernel in PASCAL by hand. This goal has lead us to the
development of PSL. 

@subsection(Goals of the Utah PSL Project)

The goal of the PSL project is to produce an efficient and transportable
Standard LISP system that may be used to:
@begin(enumeration)
Experimentally  explore
a variety of LISP implementation issues (storage management, binding,
environments, etc.).

Effectively support the REDUCE computer algebra system@cite(hearn73)
on a number of machines.

Provide the same, uniform, modern LISP programming environment on all of
the machines that we use (DEC-20, VAX/750, PDP-11/45, PERQ, and Apollo), of
the power and complexity of UCI-LISP, FranzLISP or MACLISP, with some
extensions and enhancements derived from LISP Machine LISP or CommonLISP.
@end(enumeration)

The approach we have been using is to write the @b(entire) LISP system in
Standard LISP (with extensions for dealing with 
machine words and operations), and to bootstrap it to the desired target
machine
in two steps:
@begin(enumeration)
Cross compile an appropriate kernel to the assembly language of the
target machine;

Once the kernel is running, use a resident compiler and loader, or
fast-loader, to build the rest of the system.
@end(enumeration)

 The PASLSP system, and other early implementations, have the problem that
the implementation language (PASCAL) is a distinct language from LISP, so
that communication between "system" code and "LISP" code was difficult.  We
have incorporated all of the good features of the earlier work into a new
efficient LISP-like systems language, SYSLISP, recoded all useful modules
into SYSLISP, and proceeded from there.  SYSLISP currently produces
targeted assembly code; earlier verisions were targeted at high-level
languages such as FORTRAN, PASCAL, C or ADA.  The goal is a portability
strategy that leads to an efficient enough system for a production quality,
yet portable system. We currently think of the extensions to Standard LISP
as having two levels: the SYSLISP level, dealing with words and bytes and
machine operations, enabling us to write essentially all of the kernel in
Standard LISP; and, the STDLISP level, incorporating all of the features
that make Standard LISP into a modern LISP, PSL.  SYSLISP and LISP are both
compiled by an improved version of the Portable Standard LISP Compiler. The
SYSLISP mode of the PSL compiler does compile-time folding of constants,
and more comprehensive register allocation than the previous LISP-only
version of the compiler.

The current state of PSL is fully described in an "overview" document
obtainable from the authors @cite(griss81e).  Currently PSL runs on the
DEC-20 under TOPS-20, and on the DEC VAX-11/750 under Unix.  We are now
concentrating on the MC68000 PSL for the Apollo. All of the code-generators
and assembler support is complete, and a number of large files have been
compiled from LISP to assembly code, and correctly assembled and executed
on the Apollo, testing basic I/O and arithmetic. We are now in the process
of writing the PSL support code (small functions in LAP), and testing that
various decisions about register and memory usage are correct. Based on the
development history on the VAX, we are about 1-2 months away from a
preliminary PSL on the Apollo.
@section(References)
@Bibliography

@Comment{AUXFILE of APOLLO-PASLSP.MSS.35 by Scribe 3C(1250) on 26 February 1982 at 14:47}
@AuxCitation{BENSON81$=(1;;)}
@AuxCitation{BRANDT81$=(2;;)}
@AuxCitation{GRISS79$=(3;;)}
@AuxCitation{GRISS81$=(4;;)}
@AuxCitation{GRISS81E$=(5;;)}
@AuxCitation{HEARN73$=(6;;)}
@AuxCitation{MARTI79$=(7;;)}

@Comment{ErrLog of APOLLO-PASLSP.MSS.35 by Scribe 3C(1250) on 26 February 1982 at 14:47}

Error in text found while processing the manuscript.
APOLLO-PASLSP.MSS.35 line 239:    notpair = 2;      (* a pair operation attempted on a non-pair.*)
Line too wide; lost ")".

Utah Symbolic Computation Group                     December 1981
Operating Note 60









       A PASCAL Based Standard LISP for the Apollo Domain        A PASCAL Based Standard LISP for the Apollo Domain        A PASCAL Based Standard LISP for the Apollo Domain


                               by

                 M. L. Griss and R. Ottenheimer

                 Department of Computer Science
                       University of Utah
                   Salt Lake City, Utah 84112

                      Preliminary  Version                       Preliminary  Version                       Preliminary  Version

                 Last Revision: 26 February 1982










                            ABSTRACT                             ABSTRACT                             ABSTRACT


This  report describes an interim implementation of Standard LISP
for the Apollo DOMAIN. This LISP is based upon the Standard  LISP
report,  and  a  newly  developing  Portable Standard LISP.  This
interim   implementation   is   designed    to    explore    LISP
implementations  in  PASCAL  on  the  Apollo  DOMAIN  and similar
machines.  The system consists of a kernel, handcoded in  PASCAL,
with  the  rest  of  the  system  written in LISP and compiled to
PASCAL.





Work supported in part by the National Science  Foundation  under
Grant No. MCS80-07034. Apollo Pascal LISP      26 February 1982                        1


1. Introduction 1. Introduction 1. Introduction

  In  this  preliminary  report, we describe an implementation of
Standard LISP in PASCAL, PASLSP. Versions of PASLSP have been run
on a number of machines, ranging from an LSI-11  based  TERAK  to
Apollo  and  PERQ.  This report concentrates on the Apollo DOMAIN
implementation. This report is to be read in conjunction with the
Standard LISP report [7]; we will highlight the differences  from
the  functions  documented  in  the  Standard  LISP, describe the
implementation strategy, and discuss future work.


  PASLSP is based on a series of  small  and  medium  sized  LISP
interpreters  that  have been developed at the University of Utah
to explore LISP implementations in higher level  languages.  Each
of  these  LISP  systems  consists of a small kernel handcoded in
some language, with the rest of the system written  in  LISP  and
compiled  to  the  target language.  We have used FORTRAN, PASCAL
and assembly language as targets. The PASLSP  series  use  PASCAL
for  the  kernel, and have a LISP to PASCAL compiler for the rest
of the system.


  Recent work has  concentrated  on  reducing  the  size  of  the
hand-coded  kernel,  and extending the compiler to handle systems
level constructs. This has resulted in a  new  Portable  Standard
LISP,  PSL,  running  on  the  DEC-20  and  VAX-11/750 [1, 4]. An
implementation of PSL for MC68000 is underway. The PSL system  is
a  modern, efficient LISP, written entirely in itself; it uses an
efficient LISP to machine code compiler to  produce  the  kernel,
and  then  the  rest  of LISP is loaded. In the future we hope to
produce a complete PSL targeted at a higher level languages, such
as PASCAL, C or ADA, and this will replace the current PASLSP.


1.1. History of PASLSP 1.1. History of PASLSP 1.1. History of PASLSP

  The system now  called  PASLSP  was  originally  developed  (by
M. Griss and W. Galway), as a small LISP like kernel to support a
small  computer algebra system on an LSI-11 TERAK; this was to be
used as an  answer  analysis  module  within  a  CAI  system [2],
written  entirely  in  PASCAL. It was decided to hand-code a very
small kernel, and compile additional functions  written  in  LISP
(LISP  support functions, parser and simplifier) to PASCAL, using
a modified Portable LISP compiler [3]. This version (call it  V0)
did  not  even  have  user  defined functions, since space on the
TERAK was at a premium.


  About June 1981, PASLSP came  to  the  attention  of  a  number
people  evaluating Apollo's and PERQ's, and it was suggested that
we enhance V0 PASLSP for this purpose. During the space of a  few Apollo Pascal LISP      26 February 1982                        2


days,  features  taken  from  the  Standard LISP Report and newly
developing PSL files were added to produce PASLSP-V1, running  on
a  DEC-20  and  Terak. This was a fairly complete LISP (including
Catch and Throw), but lacked a few features  (OPEN,  CLOSE,  RDS,
WRS,  PROG,  GO,  RETURN, COMPRESS, EXPLODE, Vectors and Strings,
etc.).  V1 PASLSP was adapted to a PERQ, VAX and Apollo  by  Paul
Milazo  of  Schlumberge  in  the space of a few weeks (we did not
have a PERQ or Apollo at that time).


  We subsequently obtained a PERQ and an Apollo, and recent  work
has  been  aimed  at  producing  an  enhanced  PASLSP  for  these
machines, maintaining all versions in one set  of  source  files.
The  current  system, PASLSP-V2, is produced from a single PASCAL
kernel and set  of  LISP  support  files;  the  machine  specific
features  are  handled  by  a simple Source Code Conditionalizer,
changing the definition of certain constants and data types. Only
a few features of the Standard LISP report are missing, and there
are a number of additions.


1.2. Acknowledgement 1.2. Acknowledgement 1.2. Acknowledgement

  We would like to acknowledge the contributions and  support  of
Eric Benson, Dick Brandt, Will Galway, and Paul Milazo.



2. Features of PASLSP and relation to Standard LISP 2. Features of PASLSP and relation to Standard LISP 2. Features of PASLSP and relation to Standard LISP

  PASLSP  as far as possible provides all the functions mentioned
in the attached  Standard  LISP  Report  (note  the  hand-written
comments  added  to  this  appendix);  some  of the functions are
simply stubs, so that  a  Standard  LISP  Test-file  can  be  run
without major modification.


  PASLSP-V2 does not implement the following features of Standard
LISP:


   a. VECTORS (only a simple garbage collector is used).
   b. Strings  are  implemented  as identifiers (not garbage
      collected).
   c. Integers are limited in size  (INTs  and  FIXNUMs,  no
      BIGNUMs).
   d. FLOATING Point is not implemented.
   e. IDs can not be REMOB'ed or INTERN'd.
   f. Only  3  Input  Channels  and  2  Output  Channels are
      available to OPEN, RDS,  WRS,  and  CLOSE.  Thus  file
      input  statements  can  not  be  nested very deeply in
      files. Apollo Pascal LISP      26 February 1982                        3


   g. Line,  Page  and Character counting (POSN, LPOSN, etc)
      are not implemented.


  PASLSP-V2 provides some extensions over Standard LISP:


   a. (CATCH form) and (THROW form) and the tagged versions:
      (TCATCH tag form) and (TTHROW tag form)  are  used  to
      implement error and errorset, and higher level control
      functions.
   b. Implicit PROGN in COND, and LAMBDA expressions.
   c. (WHILE pred action-1 action-2 ... action-n).
   d. (DSKIN 'filename) or (DSKIN "filename")


  PASLSP-V2  has not been extensively tested, and there may still
be a number  of  bugs.  While  some  effort  has  been  spent  in
adjusting  PASLSP  to  the  Apollo  DOMAIN,  it is clear that the
various heap sizes are not yet  optimal.    See  appendix  A  for
current  list  of  functions,  and  appendix  B for a copy of the
Standard LISP Report annotated to reflect the current  status  of
PASLSP.



3. Using PASLSP on the Apollo DOMAIN 3. Using PASLSP on the Apollo DOMAIN 3. Using PASLSP on the Apollo DOMAIN

  Initializing the system from the floppy looks like this:


Create a directory (call it pl):
        crd /pl
Mount the floppy:
        mtvol f 1 /f
Copy the files of interest:
        cpt /f/pascallisp /pl

    The files copied will be: paslsp (executable file)
                              paslsp.ini (initialization file)
                              paslsp.tst (a test file)


  Run paslsp as you would any other file.  If you get an error it
is most likely because the paslsp.ini file couldn't be found.  If
this  happens,  locate  paslsp.ini  and  try  again.  If it still
hangs,  try  calling  Ralph  Ottenheimer  at  (801)  355-0226  or
M. Griss at (801) 581-6542.


  Previously  prepared  files  of LISP (e.g., library procedures)
can be input by using the function "DSKIN".  For Example, Apollo Pascal LISP      26 February 1982                        4


(DSKIN 'Paslsp!.tst) or (DSKIN "Paslsp.tst")


would  load the paslsp test file. The PASLSP test is adapted from
an extensive test of Standard LISP  (avoiding  features  not  yet
implemented).    This  is a good excercise, try it. [Note that if
the filename is given as an ID, that special characters should be
prefaced by an "escape character", ! . This is also the case  for
filenames  in  OPEN.  Alternately the string form may be used, in
that case special characters need not be escaped.]


  Paslsp is "case-sensitive" with regard to identifiers.  All  of
the kernel procedures have upper-case identifiers associated with
them.      This  means  that  ordinarily  the  expression  (dskin
'paslsp!.tst)  would  not  be  recognized  since  "dskin"  is  in
lowercase.  However, there is a global flag !*RAISE which if true
will  convert  all  lower-case  typin to upper-case.  This Apollo
DOMAIN paslsp implementation sets !*RAISE to T as  a  default  by
having  (SETQ !*RAISE T) in the paslsp.ini file.  You may put any
special initialization code you like at the end of paslsp.ini  as
indicated  by  the  comments  in  the  file.    Toggling would be
accomplished by typing the following lisp-expressions:


        (ON !*RAISE)     equivalent to  (SETQ !*RAISE T)
        (OFF !*RAISE)    equivalent to  (SETQ !*RAISE NIL)


  Any Apollo DOMAIN filename (60 characters maximum)is  allowable
as  a paslsp filename.  Remember to prefix all special characters
with an exclamation-mark: "!".  Special  characters  include  all
non-alphanumerics.  For  example:  !*RAISE goforit!! paslsp!.test
!/login!/smith!/foo!.sl .


  If the global !*ECHO is not NIL (default is NIL), input will be
echoed  to  the  selected  output  channel.    It  is   sometimes
convienient to put:


        (SETQ !*ECHO T)


at the beginning of a file to be read by DSKIN, and:


        (SETQ !*ECHO NIL)


at the end.  This will echo the file to the screen (or to a file)
as it is read. Apollo Pascal LISP      26 February 1982                        5


  Certain low level errors do not display any explanatory message
but  instead display a numeric code (such as *** # 2), below is a
summary of these codes and their meanings:


  (* error codes.  corresponding to tag = errtag. *)
  noprspace = 1;    (* no more "pair space"--can't cons. *)
  notpair = 2;      (* a pair operation attempted on a non-pair.*
  noidspace = 3;    (* no more free identifiers *)
  undefined = 4;    (* used to mark undefined function cells *)
  noint = 5;        (* no free integer space after gc. *)
  notid = 6;        (* id was expected *)



4. Implementation of PASLSP 4. Implementation of PASLSP 4. Implementation of PASLSP


4.1. Building PASLSP 4.1. Building PASLSP 4.1. Building PASLSP

  PASLSP is built in the following steps:


  ______  _____   Kernel  files,  PAS0.PRE,  and  trailer  file  (main   program)
PASN.PRE are run through a filter program to produce PAS0.PAS and
PASN.PAS,  tailored  to  the  Apollo  DOMAIN (appropriate Include
files, Consts, etc).  This kernel provides the Basic  I/O  (Token
reading  and  printing),  handcoded storage allocator and garbage
collector, lowlevel arithmetic primitives,  lowlevel  calls  (via
Case statement) from LISP to kernel, etc.


  ____  __  ____   Rest  of  LISP, currently files PAS1.RED, PAS2.RED and PAS3.RED
are compiled to PASCAL using  a  version  of  the  Portable  LISP
Compiler  (PLC) [3].  During  compilation,  a  Symbol Table file,
PASn.SYM is read in and written  out.  These  files  record  (for
"incremental"  compilation)  the  names and ID table locations of
each ID encountered, so that the compiler can refer to an  ID  by
its  offset  in the ID table. LISP constants are also recorded in
the PASn.SYM files. PAS0.SYM is modified by hand as the kernel is
changed.


  The compilation model used  is  that  of  a  Register  Machine:
Arguments  to  LISP  functions  are passed in registers (a PASCAL
array), and the result returned in Register 1. Space is allocated
on a software stack (not the PASCAL  recursion  stack),  for  any
temporaries  or  save arguments required. Short functions usually
do not require any stack. The reason  for  this  choice  was  the
existence of the PLC (targeted at comventional machines), and the
fact  that  inline  access  to  the register array compiles quite
well, while a "PUSH/POP" stack would be much less efficient. Apollo Pascal LISP      26 February 1982                        6


  ______________   Initialization.    After  the PAS0.PAS,..PASN.PAS are produced,
the symbol  table  file  (pas3.sym)  is  converted  into  a  file
PASLSP.INI,  which  contains  the  names  of  all  ID's, the LISP
constants used, and also  ID's  for  all  kernel  functions  that
should  be known to the user LISP level. Also produced is a file,
EXEC.PAS, that contains a case statement  associating  each  user
callable  kernel  function  with  an  integer.   The PAS0.PAS ...
PASN.PAS and EXEC.PAS are compiled and linked into an  executable
file. When this file is executed, PASLSP.INI is read in:  each id
is   read   and   stored  in  the  appropriate  location  in  the
symbol-table, the kernel function names have the associated  Case
index  put  into  a function cell, and the LISP s-expressions are
READ in. Finally, some s-expressions will be executed (with care,
the user can add  his  own  expressions,  including  requests  to
(DSKIN 'library), etc.


4.2. Internal data structures 4.2. Internal data structures 4.2. Internal data structures

  The  data  spaces  (or  heaps)  in  PASLSP  are  divided into 4
sections: the pair space, id space (the oblist), string space and
large integer (fixnum) space.  These are all arrays of objects of
the appropriate type (see declarations below).    The  system  is
fully  tagged,  that is, every LISP item has associated with it a
tag field which denotes the type of the item and an 'info'  field
which  either  points  to  the  item  in an array (in the case of
pairs, identifiers and  fixnums),  or  contains  the  information
itself   (in  the  case  of  inums,  character  codes  and  error
conditions). The info field of a code pointer contains the  index
into  a case staement (see procedure 'execute') by means of which
any LISP callable function may be invoked.


itemref = RECORD
           tag:  integer;   (* Small integer denoting  type.   *)
           info: integer;   (* Item or a pointer to it         *)
                            (* depending upon the type.        *)
          END;

   pair = PACKED RECORD
            prcar: itemref;
            prcdr: itemref;
          END;

  ident = PACKED RECORD           (* identifier *)
            idname: stringp;
               val: itemref; (* value *)
             plist: itemref; (* property list *)
           funcell: itemref; (* function cell *)
           idhlink: id_ptr;  (* hash link *)
                   END; Apollo Pascal LISP      26 February 1982                        7


4.3. Adding user functions to the kernel 4.3. Adding user functions to the kernel 4.3. Adding user functions to the kernel

  It  is  fairly  easy  to  add handcoded Pascal functions to the
kernel so that  they  can  be  called  from  LISP.  For  example,
consider  adding  the  function  SQR(x), that squares its integer
argument.  Since SQR is already the name of  an  existing  PASCAL
function, we will call it "Xsqr" in PASCAL, and SQR in LISP.


  The  function  Xsqr  has  to take its argument from R[1], check
that it is an intege, square the information part, and  retag  as
integer:


PROCEDURE Xsqr;
    VAR i1 : longint;

    BEGIN
    int_val(r[1], i1);  (* Test type and extract Info *)
    mkint(i1 * i1, 1)   (* Square, retag, and put in R[1] *)
    END;


  Now  procedure  Xsqr  needs be to be installed into the EXECUTE
table, so that it can be found as the N'th code item. The  number
of  defined procedures will have to be increased by 1 in the 3'rd
line of  procedure  EXECUTE,  (currently  201  defined),  and  an
additional case added:


202:    Xsqr;


  Note  also  that  this  table  gives the Internal names of each
available procedure, should one of  these  be  required  in  your
handcoded  procedure.    Finally,  the Identifier SQR needs to be
associated with case 202 in PASLSP.INI.  Note that PASLAP.INI has
3 tables of objects, each prefixed by a count and terminated by a
0. The first is the Random ID table, consisting of  special  ID's
used  for  messages  etc.  The  second  block is for S-expression
constants, which get  loaded  into  the  base  of  the  stack  as
Globals.  The next batch are the names of LISP callable functions
in the order  corresponding  to  the  EXECUTE  procedure.  Simply
modify  the  count  form 201 to 202 (or whatever), and add SQR at
the end, just before the 0.


  In general, look for  a  sample  procedure  in  the  kernel  if
possible,  or  in  the  compiled part (although these are hard to
follow), and adapt to the specific needs. Note  the  use  of  the
ALLOC(n)  and  DEALLOC(n)  procedures  to  allocate  a  block  of
temporaries on the stack.  These  should  be  used,  rather  than Apollo Pascal LISP      26 February 1982                        8


PASCAL  VAR's, since the garbage collector may need to trace from
one of the saved objects.



5. Future work on PASLSP 5. Future work on PASLSP 5. Future work on PASLSP

  PASLSP V2 is based on a fairly old model of  a  portable  LISP,
and  has been used mainly to explore the capbilities of PASCAL as
a target language. In particular, V2 PASCAL is not  yet  powerful
enough to run the PLC compiler itself; instead, the PLC is run on
our  PSL  system on the DEC-20. In order for the full benefits of
PASLSP (or PSL) to be  realized,  the  user  should  be  able  to
compile  his  own LISP modules into PASCAL and link them with the
kernel.  In order to make the system  even  more  adapatable,  we
would  like  to  write even less of the kernel in PASCAL by hand.
This goal has lead us to the development of PSL.


5.1. Goals of the Utah PSL Project 5.1. Goals of the Utah PSL Project 5.1. Goals of the Utah PSL Project

  The goal of the PSL project is  to  produce  an  efficient  and
transportable Standard LISP system that may be used to:


   a. Experimentally    explore    a    variety    of   LISP
      implementation issues  (storage  management,  binding,
      environments, etc.).

   b. Effectively   support   the  REDUCE  computer  algebra
      system [6] on a number of machines.

   c. Provide the same,  uniform,  modern  LISP  programming
      environment  on  all  of  the  machines  that  we  use
      (DEC-20, VAX/750, PDP-11/45, PERQ, and Apollo), of the
      power  and  complexity  of  UCI-LISP,   FranzLISP   or
      MACLISP, with some extensions and enhancements derived
      from LISP Machine LISP or CommonLISP.


                                                      entire                                                       entire   The  approach  we  have  been using is to write the entire LISP
system in PSL (using LISP extensions  for  dealing  with  machine
words  and operations), and to bootstrap it to the desired target
machine in two steps:


   a. Cross compile an appropriate kernel  to  the  assembly
      language of the target machine;

   b. Once  the  kernel  is running, use a resident compiler
      and loader, or fast-loader, to build the rest  of  the
      system. Apollo Pascal LISP      26 February 1982                        9


  The  PASLSP  system,  and other early implementations, have the
problem that the implementation language (PASCAL) is  a  distinct
language  from  LISP, so that communication between "system" code
and "LISP" code was difficult.  We have incorporated all  of  the
good  features of the earlier work into a new efficient LISP-like
systems  language,  SYSLISP,  recoded  all  useful  modules  into
SYSLISP,  and  proceeded  from there.  SYSLISP currently produces
targeted  assembly  code;  earlier  verisions  were  targeted  at
high-level languages such as FORTRAN, PASCAL, C or ADA.  The goal
is  a  portability  strategy  that  leads  to an efficient enough
system  for  a  production  quality,  yet  portable  system.   We
currently  think of the extensions to Standard LISP as having two
levels: the SYSLISP level,  dealing  with  words  and  bytes  and
machine  operations,  enabling us to write essentially all of the
kernel in Standard LISP; and, the LISP level,  incorporating  all
of  the features that make PSL into a modern LISP.  Both modes of
PSL are compiled by an improved version of the Portable  Standard
LISP  Compiler.  The  SYSLISP  mode  of  the  PSL  compiler  does
compile-time  folding  of  constants,  and   more   comprehensive
register  allocation  than  the previous LISP-only version of the
compiler.


  The current state of PSL is fully described  in  an  "overview"
document  obtainable from the authors [5].  Currently PSL runs on
the DEC-20 under TOPS-20, and on the DEC VAX-11/750  under  Unix.
We  are  now concentrating on the MC68000 PSL for the Apollo. All
of the code-generators and assembler support is complete,  and  a
number  of  large  files have been compiled from LISP to assembly
code, and correctly assembled and executed on the Apollo, testing
basic I/O and arithmetic. We are now in the  process  of  writing
the  PSL  support code (small functions in LAP), and testing that
various decisions about register and memory  usage  are  correct.
Based  on  the  development  history on the VAX, we are about 1-2
months away from a preliminary PSL on the Apollo.



6. References 6. References 6. References

[1]   Benson, E. and Griss, M. L.
      _______  _ ________ ____ _____ _______ ______________       SYSLISP: A portable LISP based systems implementation
         ________          language.
      Utah Symbolic Computation Group, Report UCP-81, University
         of Utah, February, 1981.

[2]   Brandt, R. C. and Knapp, B. H.
      The University of Utah Video Computer Authoring System.
         ___________ __ ___ _________ __ ________ __________       In Proceedings of the Symposium on Learning Technology,
         pages 18-23.  Orlando, Florida, Feb, 1981. Apollo Pascal LISP      26 February 1982                       10


[3]   Griss, M. L.; Kessler, R. R.; and Maguire, G. Q. Jr.
      TLISP - A Portable LISP Implemented in P-code.
         ___________ __ _______ __       In Proceedings of EUROSAM 79, pages 490-502.  ACM, June,
         1979.

[4]   Griss, M. L. and Morrison, B.
      ___ ________ ________ ____ _____ ______       The Portable Standard LISP Users Manual.
      Utah Symbolic Computation Group,  TR-10, University of
         Utah, March, 1981.

[5]   Griss, M. L.
      ________ ________ ____  _ _____ ________       Portable Standard LISP: A Brief Overview.
      Utah Symbolic Computation Group, Operating Note 58,
         University of Utah, October, 1981.

[6]   Hearn, A. C.
      ______ _ _____ ______       REDUCE 2 Users Manual.
      Utah Symbolic Computation Group UCP-19, University of Utah,
         1973.

[7]   Marti, J. B., et al.
      Standard LISP Report.
      _______ _______       SIGPLAN Notices 14(10):48-68, October, 1979.



APPENDIX A:  A List of Current PASLSP Functions and Globals APPENDIX A:  A List of Current PASLSP Functions and Globals APPENDIX A:  A List of Current PASLSP Functions and Globals


____ ________ __________ ___ ________ ____ ______ Lisp Callable Functions, see Standard LISP Report
!*FIRST!-PROCEDURE      The top loop LISP reader
ABS
ADD1
AND
APPEND
APPLY
APPLY1                  (APPLY f (LIST u))
ASSOC
ATOM
ATSOC
CAAAAR
CAAADR
CAAAR
CAADAR
CAADDR
CAADR
CAAR
CADAAR
CADADR
CADAR
CADDAR
CADDDR Apollo Pascal LISP      26 February 1982                       11


CADDR
CADR
CAR
CATCH
CDAAAR
CDAADR
CDAAR
CDADAR
CDADDR
CDADR
CDAR
CDDAAR
CDDADR
CDDAR
CDDDAR
CDDDDR
CDDDR
CDDR
CDR
CLOSE
CODEP
COMPRESS
COND
CONS
CONSTANTP
DE
DEFLIST
DELATQ          (DELATQ 'X alist) deletes (X . any) from alist
DELETE
DELQ             Efficient DELETE (using EQ)
DF
DIFFERENCE
DIGIT
DIVIDE
DM
DN
DSKIN           (DSKIN file-id)
EOFP            (EOFP channel)
EQ
EQCAR
EQN
EQUAL
ERROR
ERRORSET
ERRPRT           Prints message with *'s
EVAL
EVLAM            Evaluates a LAMBDA expression
EVLIS
EXPAND
EXPLODE
EXPT
FASTSTAT        Prints RECLAIM message Apollo Pascal LISP      26 February 1982                       12


FIX
FIXP
FLAG
FLAG1           (FLAG (LIST x) y)
FLAGP
FLOAT
FLOATP
FLUID
FLUIDP
FUNCELL         Accesses function cell
FUNCTION
GENSYM
GET
GETD
GETV
GLOBAL
GLOBALP
GO
GREATERP
IDP
INTERN
LBIND1          Binds a single ID in LAMBDA
LBINDN
LENGTH
LESSP
LIST2           For efficent LIST compilation
LIST3
LIST4
LIST5
LITER
MAP
MAPC
MAPCAN
MAPCAR
MAPCON
MAPLIST
MAX
MAX2
MEMBER
MEMQ
MIN
MIN2
MINUS
MINUSP
MKVECT
MSGPRT
NCONC
NCONS
NOT
NULL
NUMBERP
ONEP Apollo Pascal LISP      26 February 1982                       13


OPEN
OR
ORDERP
P!.N                    Evaluates Implicit PROGNs
PAIR
PAIRP
PBIND1                  PROG binding
PBINDN
PLIST                   Access full property list
PLUS
PLUS2
PRIN1
PRIN2
PRIN2T
PRIN2TL
PRINC
PRINT
PROG
PROG2
PROGG0131
PROGN
PUT
PUTC
PUTD
PUTL
PUTV
QUOTIENT
RDEVPR          A read-eval-print loop
RDS
RDTOK
READ
READCH
RECLAIM
REMAINDER
REMD
REMFLAG
REMFLAG1
REMOB
REMPROP
RETURN
REV
REVERSE
REVX
RLIST
RPLACA
RPLACD
SASSOC
SET
SETFUNCELL
SETPLIST
SETVALUE
STRINGP         Equivalent to IDP Apollo Pascal LISP      26 February 1982                       14


SUB1
SUBLIS
SUBST
TCATCH
TERPRI
THROW
TIMES
TIMES2
TOKEN
TTHROW
UNBIND1
UNBINDN
UNBINDTO
UNFLUID
UPBV
VALUE
VECTORP
WHILE
WRS
WRTOK
XAPPLY
XCONS
ZEROP
___________ _______ Interesting Globals
!*RAISE         Raise lower case typing to upper case if not NIL
!*ECHO          Selected input to selected output if not NIL.
BSTK!*          Holds old values of rebound IDS
EMSG!*          Error message in most recent call on ERROR
ENUM!*          Error number in most recent call on ERROR.
INITFORM!*      First Expression EVAL'ed
THROWING!*      Indicates if throwing
THROWTAG!*      Indicates TAG in TTHROW
TOK!*           Holds last token scanned
TOKTYPE         Indicates type of token scanned:
                        1: integer
                        2: id
                        3: character Apollo Pascal LISP      26 February 1982                        i


                        Table of Contents                         Table of Contents                         Table of Contents

1. Introduction                                                 1
     1.1. History of PASLSP                                     1
     1.2. Acknowledgement                                       2
2. Features of PASLSP and relation to Standard LISP             2
3. Using PASLSP on the Apollo DOMAIN                            3
4. Implementation of PASLSP                                     5
     4.1. Building PASLSP                                       5
     4.2. Internal data structures                              6
     4.3. Adding user functions to the kernel                   7
5. Future work on PASLSP                                        8
     5.1. Goals of the Utah PSL Project                         8
6. References                                                   9
APPENDIX A:  A List of Current PASLSP Functions and Globals    10

@Device(lpt)
@style(justification yes)
@style(spacing 1)
@use(Bibliography "<griss.docs>mtlisp.bib")
@make(article)
@modify(enumerate,numbered=<@a. @,@i. >, spread 1)
@modify(appendix,numbered=<APPENDIX @A: >)
@modify(itemize,spread 1)
@modify(description,leftmargin +2.0 inch,indent -2.0 inch)
@define(up,use text,capitalized on,  break off)
@define(mac,use text, underline off,  break off)
@define(LISPmac,use text, underline alphanumerics,  break off)
@pageheading(Left  "Utah Symbolic Computation Group",
             Right "December 1981", 
             Line "Operating Note 60"
            )
@set(page=1)
@newpage()
@begin(titlepage)
@begin(titlebox)
@b(A PASCAL Based Standard LISP for the Apollo Domain)
@center[
by

M. L. Griss and R. Ottenheimer

Department of Computer Science
University of Utah
Salt Lake City, Utah 84112

@b(Preliminary  Version)

Last Revision: @value(date)]

@end(titlebox)
@begin(abstract)
This report describes an interim implementation of Standard LISP for the
Apollo DOMAIN. This LISP is based upon the Standard LISP report, and a
newly developing Portable Standard LISP.  This interim implementation is
designed to explore LISP implementations in PASCAL on the Apollo DOMAIN and
similar machines.  The system consists of a kernel, handcoded in PASCAL,
with the rest of the system written in LISP and compiled to PASCAL.
@End(abstract)
@begin(Researchcredit)
Work supported in part by the National Science Foundation
under Grant No. MCS80-07034.
@end(Researchcredit)
@end(titlepage)
@pageheading(Left "Apollo Pascal LISP",Center "@value(date)",
             Right "@value(Page)"
            )
@set(page=1)
@newpage
@section(Introduction)
In this preliminary report, we describe an implementation of Standard LISP
in PASCAL, PASLSP. Versions of PASLSP have been run on a number of
machines, ranging from an LSI-11 based TERAK to Apollo and PERQ. This report
concentrates on the Apollo DOMAIN implementation. This report is to be read in
conjunction with the Standard LISP report@cite(Marti79); we will
highlight the differences from the functions documented in the Standard
LISP, describe the implementation strategy, and discuss future work.

PASLSP is based on a series of small and medium sized LISP interpreters
that have been developed at the University of Utah to explore LISP
implementations in higher level languages. Each of these LISP systems
consists of a small kernel handcoded in some language, with the rest of the
system written in LISP and compiled to the target language.  We have used
FORTRAN, PASCAL and assembly language as targets. The PASLSP series use
PASCAL for the kernel, and have a LISP to PASCAL compiler for the rest of
the system. 

Recent work has concentrated on reducing the size of the hand-coded kernel,
and extending the compiler to handle systems level constructs. This has
resulted in a new Portable Standard LISP, PSL, running on the DEC-20 and
VAX-11/750@cite(Benson81,Griss81). An implementation of PSL for MC68000 is
underway. The PSL system is a modern, efficient LISP, written entirely in
itself; it uses an efficient LISP to machine code compiler to produce the
kernel, and then the rest of LISP is loaded. In the future we hope to
produce a complete PSL targeted at a higher level languages, such as
PASCAL, C or ADA, and this will replace the current PASLSP.

@subsection(History of PASLSP)
The system now called PASLSP was originally developed (by M. Griss and W.
Galway), as a small LISP like kernel to support a small computer algebra
system on an LSI-11 TERAK; this was to be used as an answer analysis module
within a CAI system@cite(Brandt81), written entirely in PASCAL. It was
decided to hand-code a very small kernel, and compile additional functions
written in LISP (LISP support functions, parser and
simplifier) to PASCAL,
using a modified Portable LISP compiler@cite(griss79). This version (call
it V0) did not even have user defined functions, since space on the TERAK
was at a premium.

About June 1981, PASLSP came to the attention of a number people evaluating
Apollo's and PERQ's, and it was suggested that we enhance V0 PASLSP for
this purpose. During the space of a few days, features taken from the
Standard LISP Report and newly developing PSL files were added to produce
PASLSP-V1, running on a DEC-20 and Terak. This was a fairly complete LISP
(including Catch and Throw), but lacked a few features (OPEN, CLOSE, RDS,
WRS, PROG, GO, RETURN, COMPRESS, EXPLODE, Vectors and Strings, etc.).  V1
PASLSP was adapted to a PERQ, VAX and Apollo by Paul Milazo of Schlumberge
in the space of a few weeks (we did not have a PERQ or Apollo at that
time).

We subsequently obtained a PERQ and an Apollo, and recent work has been
aimed at producing an enhanced PASLSP for these machines, maintaining all
versions in one set of source files.  The current system, PASLSP-V2, is
produced from a single PASCAL kernel and set of LISP support files; the
machine specific features are handled by a simple Source Code
Conditionalizer, changing the definition of certain constants and data
types. Only a few features of the Standard LISP report are missing,
and there are a number of additions.

@subsection(Acknowledgement)

We would like to acknowledge the contributions and support of
Eric Benson, Dick Brandt, Will Galway,   and Paul Milazo.

@section(Features of PASLSP and relation to Standard LISP)
PASLSP as far as possible provides all the functions mentioned
in the attached Standard LISP Report (note the hand-written
comments added to this appendix); some of the functions are simply
stubs, so that a Standard LISP Test-file can be run without major
modification.

PASLSP-V2  does not implement the following features of Standard LISP:
@begin(enumeration,spread 0)
VECTORS (only a simple garbage collector is used).

Strings are implemented as identifiers (not garbage collected).

Integers are limited in size (INTs and FIXNUMs, no BIGNUMs).

FLOATING Point is not implemented.

IDs can not be REMOB'ed or INTERN'd.

Only 3 Input Channels and 2 Output Channels are available to OPEN,
RDS, WRS, and CLOSE. Thus file input statements can not be nested
very deeply in files.

Line, Page and Character counting (POSN, LPOSN, etc) are not implemented.
@end(enumeration)

PASLSP-V2 provides some extensions over Standard LISP:
@begin(enumerate,spread 0)
(CATCH form) and (THROW form) and the tagged versions: (TCATCH tag form)
and (TTHROW tag form) are used to implement error and errorset, 
and higher level control functions.

Implicit PROGN in COND, and LAMBDA expressions.

(WHILE pred action-1 action-2 ... action-n).

(DSKIN 'filename) or (DSKIN "filename")
@end(enumerate)

PASLSP-V2 has not been extensively tested, and there may still be a number
of bugs. While some effort has been spent in adjusting PASLSP to the Apollo
DOMAIN, it is clear that the various heap sizes are not yet optimal. 
See appendix A for current list of functions, and appendix B for a copy
of the Standard LISP Report annotated to reflect the current status of 
PASLSP.

@section(Using PASLSP on the Apollo DOMAIN)
	Initializing the system from the floppy looks like this:
@begin(verbatim)
Create a directory (call it pl):
	crd /pl
Mount the floppy:
	mtvol f 1 /f
Copy the files of interest:
	cpt /f/pascallisp /pl

    The files copied will be: paslsp (executable file)
                              paslsp.ini (initialization file)
                              paslsp.tst (a test file)
@end(verbatim)

Run paslsp as you would any other file.  If you
get an error it is most likely because the paslsp.ini file couldn't be found.
If this happens, locate paslsp.ini and try again.  If it still hangs,
try calling Ralph Ottenheimer at (801) 355-0226 or M. Griss at (801) 581-6542.


Previously prepared files of LISP (e.g., library procedures)
can be input by
using the function "DSKIN".  For Example,
@begin(verbatim)
(DSKIN 'Paslsp!.tst) or (DSKIN "Paslsp.tst")
@end
would load the paslsp test file. The PASLSP test is adapted from an extensive
test of Standard LISP (avoiding features not yet implemented).  This is a
good excercise, try it. [Note that if the filename is given as an ID,
that special characters should be prefaced by an "escape character",
! . This is  also the case for filenames in OPEN.  Alternately the string
form may be used, in that case special characters need not be escaped.]

  Paslsp is "case-sensitive" with regard to identifiers.  All of the
kernel procedures have upper-case identifiers associated with them.  This
means that ordinarily the expression (dskin 'paslsp!.tst) would not be
recognized since "dskin" is in lowercase.  However, there is a global flag
!*RAISE which if true will convert all lower-case typin to upper-case.
This Apollo DOMAIN paslsp implementation sets !*RAISE to T as a default by
having (SETQ !*RAISE T) in the paslsp.ini file.  You may put any special
initialization code you like at the end of paslsp.ini as indicated by the
comments in the file.
Toggling would be accomplished by typing the following lisp-expressions:
@begin(verbatim)
	(ON !*RAISE)     equivalent to  (SETQ !*RAISE T)
        (OFF !*RAISE)    equivalent to  (SETQ !*RAISE NIL)
@end(verbatim)

	Any Apollo DOMAIN filename (60 characters maximum)is allowable
 as a paslsp filename.
Remember to prefix all special characters with an exclamation-mark: "!". 
Special characters include all non-alphanumerics. For example: !*RAISE
 goforit!! paslsp!.test !/login!/smith!/foo!.sl .

If the global !*ECHO is not NIL (default is NIL), input will be echoed to
the selected output channel.  It is sometimes convienient to put:
@begin(verbatim)
        (SETQ !*ECHO T)
@end(verbatim)
at the beginning of a file to be read by DSKIN, and:
@begin(verbatim)
        (SETQ !*ECHO NIL)
@end(verbatim)
at the end.  This will echo the file to the screen (or to a file) as it is
read. 

Certain low level errors do not display any explanatory message but
instead display a numeric code (such as *** # 2), below is a summary of these
codes and their meanings:

@begin(verbatim)
  (* error codes.  corresponding to tag = errtag. *)
  noprspace = 1;    (* no more "pair space"--can't cons. *)
  notpair = 2;      (* a pair operation attempted on non-pair.*)
  noidspace = 3;    (* no more free identifiers *)
  undefined = 4;    (* used to mark undefined function cells *)
  noint = 5;        (* no free integer space after gc. *)
  notid = 6;        (* id was expected *)
@end(verbatim)


@section(Implementation of PASLSP)
@subsection(Building PASLSP)
PASLSP is built in the following steps:

@u(Kernel files), PAS0.PRE, and trailer file (main program) PASN.PRE
are run through a filter program to produce PAS0.PAS and PASN.PAS,
tailored to the Apollo DOMAIN (appropriate Include files, Consts, etc).
This kernel provides the Basic I/O (Token reading and printing),
handcoded storage allocator and garbage collector, lowlevel arithmetic
primitives, lowlevel calls (via Case statement) from LISP to kernel, etc.

@u(Rest of LISP), currently files PAS1.RED, PAS2.RED and PAS3.RED are
compiled to PASCAL using a version of the Portable LISP Compiler
(PLC)@cite(griss79). During compilation, a Symbol Table file, PASn.SYM is
read in and written out. These files record (for "incremental" compilation)
the names and ID table locations of each ID encountered, so that the compiler
can refer to an ID by its offset in the ID table. LISP constants are also
recorded in the PASn.SYM files. PAS0.SYM is modified by hand as the kernel
is changed.  

The compilation model used is that of a Register Machine: Arguments to LISP
functions are passed in registers (a PASCAL array), and the result returned
in Register 1. Space is allocated on a software stack (not the PASCAL
recursion stack), for any temporaries or save arguments required. Short
functions usually do not require any stack. The reason for this choice was
the existence of the PLC (targeted at comventional machines), and the fact
that inline access to the register array compiles quite well, while a
"PUSH/POP" stack would be much less efficient.

@u(Initialization). 
After the PAS0.PAS,..PASN.PAS are produced,
the symbol table file (pas3.sym) is converted into a file
PASLSP.INI, which contains the names of all ID's, the LISP constants
used, and also ID's for all kernel functions that should be known to the
user LISP level. Also produced is a file, EXEC.PAS, that contains a case
statement associating each user callable kernel function with an integer.
The PAS0.PAS ... PASN.PAS and EXEC.PAS are compiled and linked into an
executable file. When this file is executed, PASLSP.INI is read in:
each id is read and stored in the appropriate location in the symbol-table,
the kernel function names have the associated Case index put into
a function cell, and the LISP s-expressions are READ in. Finally,
some s-expressions will be executed (with care, the user can add his own
expressions, including requests to (DSKIN 'library), etc.
@subsection(Internal data structures)
The data spaces (or heaps) in PASLSP are divided into 4 sections: the
pair space, id space (the oblist), string space and large integer
(fixnum) space.  These are all arrays of objects of the appropriate type
(see declarations below).  The system is fully tagged, that is, every LISP
item has associated with it a tag field which denotes the type of the item 
and an 'info' field which either points to the item in an array (in the
case of pairs, identifiers and fixnums), or contains the information 
itself (in the case of inums, character codes and error conditions). The
info field of a code pointer contains the index into a case staement (see
procedure 'execute') by means of which any LISP callable function may be
invoked.

@begin(verbatim,leftmargin 0)
itemref = RECORD
           tag:  integer;   (* Small integer denoting  type.   *)
           info: integer;   (* Item or a pointer to it         *)
                            (* depending upon the type.        *)
          END;

   pair = PACKED RECORD
            prcar: itemref;
            prcdr: itemref;
          END;

  ident = PACKED RECORD           (* identifier *)
            idname: stringp;
               val: itemref; (* value *)
             plist: itemref; (* property list *)
           funcell: itemref; (* function cell *)
           idhlink: id_ptr;  (* hash link *)
                   END;
@end(verbatim)
@subsection(Adding user functions to the kernel)
It is fairly easy to add handcoded Pascal functions to
the kernel so that they can be called from LISP. For example,
consider adding the function SQR(x), that squares its integer argument.
Since SQR is already the name of an existing PASCAL function, we will
call it "Xsqr" in PASCAL, and SQR in LISP.

The function Xsqr has to take its argument from R[1], check that it is an intege, square the information part, and retag as integer:
@begin(verbatim)
PROCEDURE Xsqr;
    VAR i1 : longint;

    BEGIN
    int_val(r[1], i1);  (* Test type and extract Info *)
    mkint(i1 * i1, 1)   (* Square, retag, and put in R[1] *)
    END;
@end(verbatim)

Now procedure Xsqr needs be to be installed into the EXECUTE table, so that
it can be found as the N'th code item. The number of defined procedures
will have to be increased by 1 in the 3'rd line of procedure EXECUTE,
(currently 201 defined), and an additional case added:
@begin(verbatim)
202:    Xsqr;
@end(verbatim)

Note also that this table gives the Internal names of each available
procedure, should one of these be required in your handcoded procedure.
Finally, the Identifier SQR needs to be associated with case 202 in
PASLSP.INI.  Note that PASLAP.INI has 3 tables of objects, each prefixed by
a count and terminated by a 0. The first is the Random ID table, consisting
of special ID's used for messages etc. The second block is for S-expression
constants, which get loaded into the base of the stack as Globals. The
next batch are the names of LISP callable functions in the order
corresponding to the EXECUTE procedure. Simply modify the count form
201 to 202 (or whatever), and add SQR at the end, just before the 0.

In general, look for a sample procedure in the kernel if possible,
or in the compiled part (although these are hard to follow), and adapt
to the specific needs. Note the use of the ALLOC(n) and DEALLOC(n)
procedures to allocate a block of temporaries on the stack.
These should be used, rather than PASCAL VAR's, since the garbage collector
may need to trace from one of the saved objects.
@Section(Future work on PASLSP)
PASLSP V2 is based on a fairly old model of a portable LISP, and
has been used mainly to explore the capbilities of PASCAL as a
target language. In particular, V2 PASCAL is not yet powerful enough to
run the PLC compiler  itself;
instead, the PLC is run on our PSL system on the DEC-20. In order for the
full benefits of PASLSP (or PSL) to be realized, the user should be able to
compile his own LISP modules into PASCAL and link them with the kernel.
In order to make the system even more adapatable, we would like to write
even less of the kernel in PASCAL by hand. This goal has lead us to the
development of PSL. 

@subsection(Goals of the Utah PSL Project)

The goal of the PSL project is to produce an efficient and transportable
Standard LISP system that may be used to:
@begin(enumeration)
Experimentally  explore
a variety of LISP implementation issues (storage management, binding,
environments, etc.).

Effectively support the REDUCE computer algebra system@cite(hearn73)
on a number of machines.

Provide the same, uniform, modern LISP programming environment on all of
the machines that we use (DEC-20, VAX/750, PDP-11/45, PERQ, and Apollo), of
the power and complexity of UCI-LISP, FranzLISP or MACLISP, with some
extensions and enhancements derived from LISP Machine LISP or CommonLISP.
@end(enumeration)

The approach we have been using is to write the @b(entire) LISP system in
PSL (using LISP extensions for dealing with 
machine words and operations), and to bootstrap it to the desired target
machine
in two steps:
@begin(enumeration)
Cross compile an appropriate kernel to the assembly language of the
target machine;

Once the kernel is running, use a resident compiler and loader, or
fast-loader, to build the rest of the system.
@end(enumeration)

 The PASLSP system, and other early implementations, have the problem that
the implementation language (PASCAL) is a distinct language from LISP, so
that communication between "system" code and "LISP" code was difficult.  We
have incorporated all of the good features of the earlier work into a new
efficient LISP-like systems language, SYSLISP, recoded all useful modules
into SYSLISP, and proceeded from there.  SYSLISP currently produces
targeted assembly code; earlier verisions were targeted at high-level
languages such as FORTRAN, PASCAL, C or ADA.  The goal is a portability
strategy that leads to an efficient enough system for a production quality,
yet portable system. We currently think of the extensions to Standard LISP
as having two levels: the SYSLISP level, dealing with words and bytes and
machine operations, enabling us to write essentially all of the kernel in
Standard LISP; and, the LISP level, incorporating all of the features that
make PSL into a modern LISP.  Both modes of PSL are compiled by an improved
version of the Portable Standard LISP Compiler. The SYSLISP mode of the PSL
compiler does compile-time folding of constants, and more comprehensive
register allocation than the previous LISP-only version of the compiler.

The current state of PSL is fully described in an "overview" document
obtainable from the authors @cite(griss81e).  Currently PSL runs on the
DEC-20 under TOPS-20, and on the DEC VAX-11/750 under Unix.  We are now
concentrating on the MC68000 PSL for the Apollo. All of the code-generators
and assembler support is complete, and a number of large files have been
compiled from LISP to assembly code, and correctly assembled and executed
on the Apollo, testing basic I/O and arithmetic. We are now in the process
of writing the PSL support code (small functions in LAP), and testing that
various decisions about register and memory usage are correct. Based on the
development history on the VAX, we are about 1-2 months away from a
preliminary PSL on the Apollo.
@section(References)
@Bibliography
@appendix(A List of Current PASLSP Functions and Globals)
@begin(verbatim,leftmargin 0)
@include(Appendix-A.table)
@end(verbatim)

@Comment{OUTLINE of APOLLO-PASLSP.MSS.35 by Scribe 3C(1250) on 26 February 1982 at 14:47}
1. Introduction                                           1 APOLLO-PASLSP.MSS.35 line 54
  1.1. History of PASLSP                                  1 APOLLO-PASLSP.MSS.35 line 82
  1.2. Acknowledgement                                    2 APOLLO-PASLSP.MSS.35 line 114
2. Features of PASLSP and relation to Standard LISP       2 APOLLO-PASLSP.MSS.35 line 119
3. Using PASLSP on the Apollo DOMAIN                      3 APOLLO-PASLSP.MSS.35 line 165
4. Implementation of PASLSP                               5 APOLLO-PASLSP.MSS.35 line 248
  4.1. Building PASLSP                                    5 APOLLO-PASLSP.MSS.35 line 249
  4.2. Internal data structures                           6 APOLLO-PASLSP.MSS.35 line 291
  4.3. Adding user functions to the kernel                7 APOLLO-PASLSP.MSS.35 line 324
5. Future work on PASLSP                                  8 APOLLO-PASLSP.MSS.35 line 367
  5.1. Goals of the Utah PSL Project                      8 APOLLO-PASLSP.MSS.35 line 379
6. References                                             9 APOLLO-PASLSP.MSS.35 line 439
APPENDIX A:  A List of Current PASLSP Functions and Glo  10 APOLLO-PASLSP.MSS.35 line 441
 Table of Contents                                        1 -SCRIBE-SCRATCH-.25-4-1.100025 line 3
	Alphabetic Listing of Cross-Reference Tags and Labels

Tag or Label Name                    Page   Label Value  Source file Location
-----------------------------------------------------------------------------

@u[Lisp Callable Functions, see Standard LISP Report]
!*FIRST!-PROCEDURE	The top loop LISP reader
ABS
ADD1
AND
APPEND
APPLY
APPLY1                  (APPLY f (LIST u))
ASSOC
ATOM
ATSOC
CAAAAR
CAAADR
CAAAR
CAADAR
CAADDR
CAADR
CAAR
CADAAR
CADADR
CADAR
CADDAR
CADDDR
CADDR
CADR
CAR
CATCH
CDAAAR
CDAADR
CDAAR
CDADAR
CDADDR
CDADR
CDAR
CDDAAR
CDDADR
CDDAR
CDDDAR
CDDDDR
CDDDR
CDDR
CDR
CLOSE
CODEP
COMPRESS
COND
CONS
CONSTANTP
DE
DEFLIST
DELATQ 		(DELATQ 'X alist) deletes (X . any) from alist
DELETE
DELQ             Efficient DELETE (using EQ)
DF
DIFFERENCE
DIGIT
DIVIDE
DM
DN
DSKIN		(DSKIN file-id)
EOFP            (EOFP channel)
EQ
EQCAR
EQN
EQUAL
ERROR
ERRORSET
ERRPRT           Prints message with *'s
EVAL
EVLAM            Evaluates a LAMBDA expression
EVLIS
EXPAND
EXPLODE
EXPT
FASTSTAT 	Prints RECLAIM message
FIX
FIXP
FLAG
FLAG1	        (FLAG (LIST x) y)
FLAGP
FLOAT
FLOATP
FLUID
FLUIDP
FUNCELL	        Accesses function cell
FUNCTION
GENSYM
GET
GETD
GETV
GLOBAL
GLOBALP
GO
GREATERP
IDP
INTERN
LBIND1		Binds a single ID in LAMBDA
LBINDN
LENGTH
LESSP
LIST2	        For efficent LIST compilation
LIST3
LIST4
LIST5
LITER
MAP
MAPC
MAPCAN
MAPCAR
MAPCON
MAPLIST
MAX
MAX2
MEMBER
MEMQ
MIN
MIN2
MINUS
MINUSP
MKVECT
MSGPRT
NCONC
NCONS
NOT
NULL
NUMBERP
ONEP
OPEN
OR
ORDERP
P!.N			Evaluates Implicit PROGNs
PAIR
PAIRP
PBIND1			PROG binding
PBINDN
PLIST			Access full property list
PLUS
PLUS2
PRIN1
PRIN2
PRIN2T
PRIN2TL
PRINC
PRINT
PROG
PROG2
PROGG0131
PROGN
PUT
PUTC
PUTD
PUTL
PUTV
QUOTIENT
RDEVPR			A read-eval-print loop
RDS
RDTOK
READ
READCH
RECLAIM
REMAINDER
REMD
REMFLAG
REMFLAG1
REMOB
REMPROP
RETURN
REV
REVERSE
REVX
RLIST
RPLACA
RPLACD
SASSOC
SET
SETFUNCELL
SETPLIST
SETVALUE
STRINGP		Equivalent to IDP
SUB1
SUBLIS
SUBST
TCATCH
TERPRI
THROW
TIMES
TIMES2
TOKEN
TTHROW
UNBIND1
UNBINDN
UNBINDTO
UNFLUID
UPBV
VALUE
VECTORP
WHILE
WRS
WRTOK
XAPPLY
XCONS
ZEROP
@u[Interesting Globals]
!*RAISE		Raise lower case typing to upper case if not NIL
!*ECHO          Selected input to selected output if not NIL.
BSTK!*		Holds old values of rebound IDS
EMSG!*		Error message in most recent call on ERROR
ENUM!*		Error number in most recent call on ERROR.
INITFORM!*      First Expression EVAL'ed
THROWING!*	Indicates if throwing
THROWTAG!*      Indicates TAG in TTHROW
TOK!*		Holds last token scanned
TOKTYPE		Indicates type of token scanned:
			1: integer
			2: id
			3: character

pascal
s:PL20.rel
S:PL20.lst
S:PL20.PAS/debug
load S:PL20.REL
save S:PL20.EXE

forward;
(* !(!*ENTRY DELETE EXPR !2!) *)
(*  EXPR DELETE *)
procedure PAS227;
label
      102,
      101,
      100;
begin
(* !(!*ALLOC !2!) *)
    alloc2;
(* !(!*STORE !1 !0!) *)
      store10;
(* !(!*STORE !2 !-!1!) *)
      store(2,1);
(* !(!*JUMPC G!0!0!9!9 !2 PAIRTAG!) *)
      IF tag_of(R[2]) = PAIRTAG THEN GOTO 100;
(* !(!*LOAD !1 !(QUOTE NIL!)!) *)
      R[1] := nilref;
(* !(!*JUMP G!0!1!0!1!) *)
      GOTO 102;
(* !(!*LBL G!0!0!9!9!) *)
100: 
(* !(!*LOAD !2 !(CAR !2!)!) *)
   ANYcar(R[2],R[2]);
(* !(!*LINK EQUAL EXPR !2!) *)
     PAS226;
(* !(!*JUMPNIL G!0!1!0!0!) *)
      IF R[1] = nilref THEN GOTO 101;
(* !(!*LOAD !1 !(CDR !-!1!)!) *)
   ANYcdr(stk[st-1],R[1]);
(* !(!*JUMP G!0!1!0!1!) *)
      GOTO 102;
(* !(!*LBL G!0!1!0!0!) *)
101: 
(* !(!*LOAD !2 !(CDR !-!1!)!) *)
   ANYcdr(stk[st-1],R[2]);
(* !(!*LOAD !1 !0!) *)
      load10;
(* !(!*LINK DELETE EXPR !2!) *)
     PAS227;
(* !(!*LOAD !2 !(CAR !-!1!)!) *)
   ANYcar(stk[st-1],R[2]);
(* !(!*LINK XCONS EXPR !2!) *)
     XXCONS;
(* !(!*LBL G!0!1!0!1!) *)
102: 
(* !(!*DEALLOC !2!) *)
      dealloc2;
(* !(!*EXIT!) *)
end;
procedure PAS228;
forward;
(* !(!*ENTRY DELQ EXPR !2!) *)
(*  EXPR DELQ *)
procedure PAS228;
label
      102,
      101,
      100;
begin
(* !(!*ALLOC !1!) *)
    alloc1;
(* !(!*STORE !2 !0!) *)
      store(2,0);
(* !(!*JUMPC G!0!1!0!5 !2 PAIRTAG!) *)
      IF tag_of(R[2]) = PAIRTAG THEN GOTO 100;
(* !(!*LOAD !1 !2!) *)
      R[1] := R[2];
(* !(!*JUMP G!0!1!0!7!) *)
      GOTO 102;
(* !(!*LBL G!0!1!0!5!) *)
100: 
(* !(!*JUMPN G!0!1!0!6 !(CAR !2!)!) *)
   ANYcar(R[2],RXX);
      IF R[1] <> RXX THEN GOTO 101;
(* !(!*LOAD !1 !(CDR !2!)!) *)
   ANYcdr(R[2],R[1]);
(* !(!*JUMP G!0!1!0!7!) *)
      GOTO 102;
(* !(!*LBL G!0!1!0!6!) *)
101: 
(* !(!*LOAD !2 !(CDR !2!)!) *)
   ANYcdr(R[2],R[2]);
(* !(!*LINK DELQ EXPR !2!) *)
     PAS228;
(* !(!*LOAD !2 !(CAR !-!1!)!) *)
   ANYcar(stk[st-1],R[2]);
(* !(!*LINK XCONS EXPR !2!) *)
     XXCONS;
(* !(!*LBL G!0!1!0!7!) *)
102: 
(* !(!*DEALLOC !1!) *)
      dealloc1;
(* !(!*EXIT!) *)
end;

Subject: PASLSP TEST
To: GRISS
cc: CAI.OTTENHEIMER

(DSKIN "PASLSP.TST") croaks on the 20 also, ends up with inf. recursion.

function caar(x: any): any;
    begin
    caar := car(car(x))
    end;

function cadr(x: any): any;
    begin
    cadr := car(cdr(x))
    end;

function cdar(x: any): any;
    begin
    cdar := car(cdr(x))
    end;

function cddr(x: any): any;
    begin
    cddr := cdr(cdr(x))
    end;

function prin2(x: any): any;
    begin
    end;

function rev(l1: any): any;
    begin
    end;

function notnull(x: any): any;
    begin 
    notnull := x
    end;

function list2(r1, r2: any): any;
    begin
    list2 := cons(r1, ncons(r2))
    end;

function list3(r1, r2, r3: any): any;
    begin
    list3 := cons(r1, list2(r2, r3))
    end;

function list4(r1, r2, r3, r4: any): any;
    begin
    list4 := cons(r1, list3(r2, r3, r4))
    end;

function list5(r1, r2, r3, r4, r5: any): any;
    begin
    list5 := cons(r1, list4(r2, r3, r4, r5))
    end;

function reverse(u: any): any;
    begin
    reverse := rev(u)
    end;

function append(u, v: any): any;
    function append1: any;
        begin
	junk := setq(u, reverse(u));
	while truep(pairp(u)) do
	    begin
	    junk := setq(v, cons(car(u), v));
	    junk := setq(u, cdr(u))	(* a hard case *)
	    end;
	append := v	(* goto also needed? *)
	end;

    begin
    append := append1;
    end;

	(* procedures to support get & put. *)
function memq(u, v: any): any;
    begin
    if truep(xnot(pairp(v))) then memq := v
    else if truep(eq(u, car(v))) then memq := v
    else memq := memq(u, cdr(v))
    end;

function atsoc(u, v: any): any;
    begin
    if truep(xnot(pairp(v))) then atsoc := v
    else if truep(xnot(pairp(v))) or truep(xnot(eq(u, caar(v)))) then
	atsoc := atsoc(u, cdr(v))
    else atsoc := car(v)
    end;

function delq(u, v: any): any;
    begin
    if truep(xnot(pairp(v))) then delq := v
    else if truep(eq(u, car(v))) then delq := cdr(v)
    else delq := cons(car(v), delq(u, cdr(v)))
    end;

function delatq(u, v: any): any;
    begin
    if truep(xnot(pairp(v))) then delatq := v
    else if truep(xnot(pairp(car(v)))) or truep(xnot(eq(u, caar(v)))) then
	delatq := cons(car(v), delatq(u, cdr(v)))
    else delatq := cdr(v)
    end;

function get(u, v:any): any;
    begin
    if truep(xnot(idp(u))) then get := xnil
    else if truep(pairp(setq(u, atsoc(v, plist(u))))) then get := cdr(u)
    else get := xnil
    end;

function put(u, v, ww: any): any;
    function put1: any;
        label 1;
        var l: any;
	begin
	if truep(xnot(idp(u))) then
	    begin
	    put1 := ww;
	    goto 1
	    end;
	junk := setq(l, plist(u));
	if truep(atsoc(v, l)) then junk := delatq(v, l);
	if truep(notnull(ww)) then junk := setq(l, cons(cons(v, ww), l));
	junk := setplist(u, l);
	begin
	put1 := ww;
	goto 1
	end;
	1:
	end;

    begin
    put := put1
    end;

function remprop(u, v: any): any;
    begin
    remprop := put(u, v, xnil)
    end;

function eqcar(u, v: any): any;
    begin
    if truep(pairp(u)) then
	if truep(eq(car(u), v)) then eqcar := t
	else eqcar := xnil
    end;

function null(u: any): any;
    begin
    null := eq(u, xnil)
    end;

function equal(x, y: any): any;
    begin
    if truep(atom(x)) then
	if truep(atom(y)) then
	    equal := eq(x, y)
	else equal := xnil
    else if truep(atom(y)) then equal := xnil
    else if truep(equal(car(x), car(y))) then
	if truep(equal(cdr(x), cdr(y))) then equal := t
	else equal := xnil
    else equal := xnil
    end;

function read;
    begin
    end;

(* include following two lines for terak *)
(*  [$s+] *) (* swapping mode to manage this large file *)
(*  [$g+] *) (* goto is legal *)

PROGRAM Paslsp(symin, input, output);

    (************************************************************)
    (* this file contains global data declarations and          *)
    (* function definitions to support a sub-standard lisp      *)
    (* system.  it is used with a compiler which compiles lisp  *)
    (* to pascal source code. this file is divided into the     *)
    (* following sections:                                      *)
    (*     1. constant, type & global variable declarations.    *)
    (*     2. lisp item selectors & constructors - these are    *)
    (*        the functions which know about the internal       *)
    (*        (pascal) representation of lisp data primitives.  *)
    (*        currently these are: integers (-4096..4095),      *)
    (*        characters, dotted pairs, identifiers,            *)
    (*        code pointers, error conditions, large integers & *)
    (*        floating point numbers (most hooks exist).        *)
    (*     3. stack allocation - variables local to a function  *)
    (*        are kept on a stack.                              *)
    (*     4. the garbage collector.                            *)
    (*     5. identifier lookup & entry - symbol table          *)
    (*        management.                                       *)
    (*     6. standard lisp functions - pascal implementations  *)
    (*        taking lisp items as arguments and returning a    *)
    (*        lisp item. more standard lisp functions are found *)
    (*        in lspfns.red.                                    *)
    (*     7. i/o primitives (not callable from lisp functions).*)
    (*     8. a lisp callable token scanner.                    *)
    (*     9. initialization.                                   *)
    (*    10. apply                                             *)
    (************************************************************)
    (* symin is input channel one--used to initialize "symbol   *)
    (* table".  input is input channel two--standard input.     *)
    (* output is output channel one--the standard output.       *)
    (************************************************************)
    (* written by martin l. griss, william f. galway and        *)
    (* ralph ottenheimer.                                       *)
    (* last changed 16 june 1981                                *)
    (************************************************************)

CONST

    (* constants relating to input / output *)
    sp = ' ';
    nul = 0;          (* ascii codes *)
    ht = 9;
    lf = 10;
    cr = 13;

    inchns = 2;       (* number of input channels.  *)
    outchns = 1;      (* number of output channels. *)
    eofcode = 26;     (* magic character code for eof, ascii for *)
    (*                   cntrl-z.   kludge, see note in rdtok.  *)
    choffset = 1;     (* add choffset to ascii code to get address  *)
    (*                   in id space for corresponding identifier.  *)
    eos = nul;        (* terminator character for strings. *)

    (* constants relating to the token scanner *)
    toktype  =  129; (* slot in idspace for toktype. *)
    chartype  =  3;   (* various token types *)
    inttype  =  1;
    idtype  =  2;

    (* constants relating to lisp data types and their representations. *)
    shift_const = 8192; (* tags and info are packed into an integer *)
    (* assumed to be at least 16 bits long.  low order 13 bits  *)
    (* are the info, top 3 are the tag.                         *)
    int_offset = 4096;  (* small integers are stored 0..8191    *)
    (* instead of -4096..4095 because it will pack smaller      *)
    (* under ucsd pascal.                                       *)
    end_flag = -1;  (* marks end of fixnum free list. *)

    (* the various tags - can't use a defined scalar type *)
    (* because of the lack of convertion functions.       *)
    inttag = 0;    (* info is an integer                  *)
    chartag = 1;   (* info is a character code            *)
    pairtag = 2;   (* info points to pair                 *)
    idtag = 3;     (* info points to identifier           *)
    codetag = 4;   (* info is index into a case statement *)
    (*                that calls appropriate function.    *)
    errtag = 5;    (* info is an error code - see below.  *)
    fixtag = 6;    (* info points to a full word (or      *)
    (*                longer) integer.                    *)
    flotag = 7;    (* info points to a float number.      *)

    (* error codes.  corresponding to tag = errtag.  *)
    noprspace = 1;    (* no more "pair space"--can't cons. *)
    notpair = 2;      (* a pair operation attempted on a non-pair. *)
    noidspace = 3;    (* no more free identifiers *)
    undefined = 4;    (* used to mark undefined function cells (etc?) *)

    (* constants relating to data space *)
    maxpair = 2500;   (* max number of pairs allowed. *)
    maxident = 400;   (* max number of identifiers *)
    maxstrsp = 2000;  (* size of string (literal) storage space. *)
    maxintsp = 50;    (* max number of long integers allowed *)
    maxflosp = 2;     (* max number of floating numbers allowed *)
    maxgcstk = 100;   (* size of garbage collection stack.    *)
    stksize = 500;    (* stack size *)

    (* constants relating to the symbol table. *)
    hidmax = 50;      (* number of hash values for identifiers *)
    nillnk = 0;       (* when integers are used as pointers.  *)


TYPE
    onechar = char;

    (* note we allow zero for id_ptr, allowing a "nil" link. *)
    stringp = 1..maxstrsp;        (* pointer into string space. *)
    id_ptr = 0..maxident;         (* pointer into id space. *)

    any = integer;  (* your basic lisp item *)
    itemtype = 0..7;    (* the tags *)


    pair = PACKED RECORD
		      prcar: any;
		      prcdr: any;
		      markflg: boolean;        (* for garbage collection   *)
		  END;


    ascfile = PACKED FILE OF onechar;

    ident = PACKED RECORD           (* identifier *)
		       idname: stringp;
		       val: any;       (* value *)
		       plist: any;     (* property list *)
		       funcell: any;   (* function cell *)
		       idhlink: id_ptr;    (* hash link *)
		   END;
    longint = integer;  (* use integer[n] on terak *)

VAR
    (* global information *)
    xnil, t: any;    (* refers to identifiers "nil", and "t". *)
    junk: any;     (* global to hold uneeded function results *)
    old_binds: any;	(* saved fluid bindings *)

    (* "st" is the stack pointer into "stk".  it counts the number of  *)
    (* items on the stack, so it runs from zero while the stack starts *)
    (* at one.                                                         *)
    st: 0..stksize;
    stk: ARRAY[1..stksize] OF any;

    (* pair space *)
    prspace: PACKED ARRAY[1..maxpair] OF pair; (* all pairs stored here. *)
    freepair: integer;          (* pointer to next free pair in prspace. *)

    (* identifier space *)
    idhead: ARRAY[0..hidmax] OF id_ptr;
    idspace: PACKED ARRAY[1..maxident] OF ident;
    freeident: integer;

    (* string space *)
    strspace: PACKED ARRAY[1..maxstrsp] OF onechar;
    freestr: stringp;

    (* large integer space *)
    intspace: ARRAY[1..maxintsp] OF longint;
    freeint: 1..maxintsp;

    (* floating point number space *)
    flospace: ARRAY[1..maxflosp] OF real;
    freefloat: 1..maxflosp;

    (* i/o channels *)
    symin: ascfile;
    input: ascfile; (* comment out for terak. *)

    inchnl: 1..inchns;      (* current input channel number  *)
    outchnl: 1..outchns;    (* current output channel number *)

    (* "current character" for each input channel.                    *)
    (* may want to include more than one character at some later date *)
    (* (for more lookahead).                                          *)
    ichrbuf: ARRAY[1..inchns] OF onechar;

    (* for collecting statistics. *)
    gccount: integer;           (* counts garbage collections *)
    (* counts from last garbage collection. *)
    consknt: integer;           (* number of times "cons" called *)
    pairknt: integer;           (* number of pairs created *)


    (********************************************************)
    (*                                                      *)
    (*             item selectors & constructors            *)
    (*                                                      *)
    (********************************************************)

FUNCTION Truep(predicate: any): boolean;
    BEGIN (* truep *)
    Truep := predicate <> xnil
    END  (* truep *);

FUNCTION Falsep(predicate: any): boolean;
    BEGIN (* Falsep *)
    Falsep := predicate = xnil
    END (* Falsep *);

FUNCTION Tag_of(item: any): itemtype;
    BEGIN (* tag_of *)
    Tag_of := item DIV shift_const;
    END;
    (* tag_of *)

FUNCTION Info_of(item: any): integer;
    BEGIN (* info_of *)
    IF item DIV shift_const = inttag THEN
	Info_of := item MOD shift_const - int_offset
    ELSE
	Info_of := item MOD shift_const
    END;
    (* info_of *)

FUNCTION Mkitem(tag: itemtype; info: longint): any;
    (* do range checking on info. ints run from -4096 to +4095 *)
    (* everything else runs from 0 to 8191. ints & chars       *)
    (* contain their info, all others points into an           *)
    (* appropriate space.                                      *)

    BEGIN (* mkitem *)
    IF info < 0 THEN        (* this check probably not necessary *)
	Writeln('*****MKITEM: BAD NEG');

    (* pack tag and info into 16-bit item.   *)
    Mkitem := tag * shift_const + info
    END    (* mkitem *);


PROCEDURE Set_info(VAR item: any; newinfo: longint);
    BEGIN (* set_info *)
    item := Mkitem(Tag_of(item), newinfo)
    END;
    (* set_info *)

PROCEDURE Set_tag(VAR item: any; newtag: itemtype);
    BEGIN (* set_tag *)
    item := Mkitem(newtag, Info_of(item))
    END;
    (* set_tag *)

FUNCTION Mkident(id: integer): any;
    BEGIN       (* mkident *)
    Mkident := Mkitem(idtag, id);
    END;
    (* mkident *)

FUNCTION Car(u: any): any; FORWARD;
FUNCTION Cdr(u: any): any; FORWARD;
FUNCTION Pairp(item: any): any; FORWARD;

FUNCTION Mkfixint(fixint: longint): any;
    VAR p: integer;

    PROCEDURE Gc_int;       (* Garbage collect large integer space. *)
	VAR i: integer;
	    mark_flag: PACKED ARRAY[1..maxintsp] OF boolean;

	PROCEDURE Mark(u: any);
	    BEGIN (* mark *)
	    IF Truep(Pairp(u)) THEN
		BEGIN
		Mark(Car(u));
		Mark(Cdr(u))
		END
	    ELSE IF Tag_of(u) = fixtag THEN
		mark_flag[Info_of(u)] := true
	    END; (* mark *)

	BEGIN (* gc_int *)
	FOR i := 1 TO maxintsp DO       (* clear mark flags *)
	    mark_flag[i] := false;

	FOR i := 1 TO st DO             (* mark from the stack *)
	    Mark(stk[i]);

	FOR i := 1 TO maxident DO       (* mark from the symbol table *)
	    BEGIN
	    Mark(idspace[i].val);
	    Mark(idspace[i].plist);
	    Mark(idspace[i].funcell)
	    END;

	(* reconstruct free list *)
	FOR i := 1 TO maxintsp - 1 DO
	    IF NOT mark_flag[i] THEN
		BEGIN
		intspace[i] := freeint;
		freeint := i
		END
	END; (* gc_int *)


    BEGIN (* mkfixint *)
    IF intspace[freeint] = end_flag THEN Gc_int;
    IF intspace[freeint] <> end_flag THEN     (* convert to fixnum *)
	BEGIN
	p := freeint;
	freeint := intspace[freeint];
	Mkfixint := Mkitem(fixtag, p);
	intspace[p] := fixint
	END
    ELSE Writeln('*****FIXNUM SPACE EXHAUSTED')
    END  (* mkfixint *);

FUNCTION Mkint(int: longint): any;
    BEGIN       (* mkint *)
    IF (int < -int_offset) OR (int > int_offset - 1) THEN
	Mkint := Mkfixint(int)
    ELSE
	Mkint := Mkitem(inttag, int + int_offset)
	(* int was in range so add offset *)
    END    (* mkint *);

FUNCTION Mkpair(pr: integer): any;
    BEGIN (* mkpair *)
    Mkpair := Mkitem(pairtag, pr)
    END;
    (* mkpair *)

PROCEDURE Int_val(item: any; VAR number: longint);
    (* returns integer value of item (int or fixnum). *)
    (* must return 'number' in var parameter instead  *)
    (* of function value since long integers are not  *)
    (* a legal function type in ucsd pascal.          *)
    BEGIN (* int_val *)
    IF Tag_of(item) = inttag THEN
	number := Info_of(item)
    ELSE IF Tag_of(item) = fixtag THEN
	number := intspace[Info_of(item)]
    ELSE Writeln('***** ILLEGAL DATA TYPE FOR NUMERIC OPERATION')
    END    (* int_val *);


    (********************************************************)
    (*                                                      *)
    (*                  stack allocation                    *)
    (*                                                      *)
    (********************************************************)

PROCEDURE Alloc(n: integer);
    BEGIN
    IF n + st <= stksize THEN
	st := n+st
    ELSE
	BEGIN
	Writeln('*****LISP STACK OVERFLOW');
	Writeln('     TRIED TO ALLOCATE ',n);
	Writeln('     CURRENT STACK TOP IS ',st);
	END;
    END;

PROCEDURE Dealloc(n: integer);
    BEGIN
    IF st - n >= 0 THEN
	st := st - n
    ELSE
	Writeln('*****LISP STACK UNDERFLOW');
    END;

    (* optimized allocs *)

PROCEDURE Alloc1;
    BEGIN Alloc(1) END;

PROCEDURE Dealloc1;
    BEGIN Dealloc(1) END;

PROCEDURE Alloc2;
    BEGIN Alloc(2) END;

PROCEDURE Dealloc2;
    BEGIN Dealloc(2) END;

PROCEDURE Alloc3;
    BEGIN Alloc(3) END;

PROCEDURE Dealloc3;
    BEGIN Dealloc(3) END;


    (********************************************************)
    (*                                                      *)
    (*              the garbage collector                   *)
    (*                                                      *)
    (********************************************************)

PROCEDURE Faststat;
    (* give quick summary of statistics gathered *)
    BEGIN
    Writeln('CONSES:',consknt);
    Writeln('PAIRS :',pairknt);
    Writeln('CONSES/PAIRS: ',consknt/pairknt);
    Writeln('ST    :',st);
    END;


PROCEDURE Gcollect;
    VAR
	i: integer;
	markedk: integer;   (* counts the number of pairs marked *)
	freedk: integer;    (* counts the number of pairs freed. *)
	gcstkp: 0..maxgcstk; (* note the garbage collection stack   *)
	mxgcstk: 0..maxgcstk;           (* is local to this procedure. *)
	gcstk: ARRAY[1..maxgcstk] OF integer;

    PROCEDURE Pushref(pr: any);
	(* push the address of an unmarked pair, if that's what it is. *)
	BEGIN
	IF Tag_of(pr) = pairtag THEN
	    IF NOT prspace[Info_of(pr)].markflg THEN
		BEGIN
		IF gcstkp < maxgcstk THEN
		    BEGIN
		    gcstkp := gcstkp + 1;
		    gcstk[gcstkp] := Info_of(pr);
		    IF gcstkp > mxgcstk THEN
			mxgcstk := gcstkp;
		    END
		ELSE
		    Writeln('*****GARBAGE STACK OVERFLOW');
		(* fatal error *)
		END;
	END;

    PROCEDURE Mark;
	(* "recursively" mark pairs referred to from gcstk. gcstk is used to *)
	(* simulate recursion.                                               *)
	VAR
	    prloc: integer;
	BEGIN
	WHILE gcstkp > 0 DO
	    BEGIN
	    prloc := gcstk[gcstkp];
	    gcstkp := gcstkp - 1;
	    prspace[prloc].markflg := true;
	    Pushref(prspace[prloc].prcdr);
	    Pushref(prspace[prloc].prcar);  (* trace the car first. *)
	    END;
	END;

    BEGIN       (* gcollect *)
    Writeln('***GARBAGE COLLECTOR CALLED');
    gccount := gccount + 1;          (* count garbage collections. *)
    Faststat;   (* give summary of statistics collected *)
    consknt := 0;       (* clear out the cons/pair counters *)
    pairknt := 0;
    gcstkp := 0;                    (* initialize the garbage stack pointer. *)
    mxgcstk := 0;                   (* keeps track of max stack depth. *)

    (* mark things from the "computation" stack. *)
    FOR i := 1 TO st DO
	BEGIN
	Pushref(stk[i]);
	Mark;
	END;
    (* mark things from identifier space. *)
    FOR i := 1 TO maxident DO
	BEGIN
	Pushref(idspace[i].val);
	Mark;
	Pushref(idspace[i].plist);
	Mark;
	Pushref(idspace[i].funcell);
	Mark;
	END;

    (* reconstruct free list by adding things to the head. *)
    freedk := 0;
    markedk := 0;
    FOR i:= 1 TO maxpair - 1 DO
	BEGIN
	IF prspace[i].markflg THEN
	    BEGIN
	    markedk := markedk + 1;
	    prspace[i].markflg := false
	    END
	ELSE
	    BEGIN
	    prspace[i].prcar := xnil;
	    prspace[i].prcdr := Mkitem(pairtag, freepair);
	    freepair := i;
	    freedk := freedk + 1
	    END
	END (* for *);
    Writeln(freedk,' PAIRS FREED.');
    Writeln(markedk,' PAIRS IN USE.');
    Writeln('MAX GC STACK WAS ',mxgcstk);
    END    (* gcollect *);


    (********************************************************)
    (*                                                      *)
    (*              identifier lookup & entry               *)
    (*                                                      *)
    (********************************************************)

FUNCTION Nmhash(nm: stringp): integer;
    CONST
	hashc = 256;
    VAR
	i,tmp: integer;
    BEGIN
    tmp := 0;
    i := 1;     (* get hash code from first three chars of string. *)
    WHILE (i <= 3) AND (strspace[nm+i] <> Chr(eos)) DO
	BEGIN
	tmp := Ord(strspace[nm+i]) + hashc*tmp;
	i := i + 1;
	END;
    Nmhash := Abs(tmp) MOD hidmax;      (* abs because mod is screwy. *)
    END;

FUNCTION Eqstr(s1,s2: stringp): boolean;
    BEGIN
    WHILE (strspace[s1] = strspace[s2]) AND (strspace[s1] <> Chr(eos)) DO
	BEGIN
	s1 := s1 + 1;
	s2 := s2 + 1;
	END;
    Eqstr := (strspace[s1] = strspace[s2]);
    END;

PROCEDURE Nmlookup(nm: stringp; VAR found: boolean; VAR hash: integer;
		   VAR loc: any);
    (* lookup a name in "identifier space".                                 *)
    (* "hash" returns the hash value for the name.                          *)
    (* "loc" returns the location in the space for the (possibly new)       *)
    (* identifier.                                                          *)
    BEGIN
    hash := Nmhash(nm);
    loc := Mkitem(idtag, idhead[hash]);
    (* default is identifier, but may be "error". *)
    (* start at appropriate hash chain. *)

    found := false;
    WHILE (Info_of(loc) <> nillnk) AND (NOT found) DO
	BEGIN
	found := Eqstr(nm, idspace[Info_of(loc)].idname);
	IF NOT found THEN
	    Set_info(loc, idspace[Info_of(loc)].idhlink);
	(* next id in chain *)
	END;
    IF NOT found THEN               (* find spot for new identifier *)
	BEGIN
	IF freeident=nillnk THEN    (* no more free identifiers. *)
	    loc := Mkitem(errtag, noidspace)
	ELSE
	    BEGIN
	    Set_info(loc, freeident);
	    freeident := idspace[freeident].idhlink;
	    END;
	END;
    END;

PROCEDURE Putnm(nm: stringp; VAR z: any; VAR found: boolean);
    (* put a new name into identifier space, or return old location *)
    (* if it's already there.                                       *)
    VAR
	tmp: ident;
	hash: integer;
    BEGIN
    Nmlookup(nm, found, hash, z);
    IF (NOT found) AND (Tag_of(z) = idtag) THEN
	BEGIN
	tmp.idname := nm;
	tmp.idhlink := idhead[hash];   (* put new ident at head of chain     *)
	tmp.val := xnil;             (* initialize value and property list *)
	tmp.plist := xnil;
	tmp.funcell := xnil;         (* also, the function cell *)
	idhead[hash] := Info_of(z);
	idspace[Info_of(z)] := tmp;
	END;
    END;

    (********************************************************)
    (*                                                      *)
    (*               standard lisp functions                *)
    (*                                                      *)
    (********************************************************)

    (* the following standard lisp functions appear in *)
    (* lspfns.red: reverse, append, memq, atsoc, get,  *)
    (* put, remprop, eq, null, equal, error, errorset, *)
    (* abs, idp, numberp, atom, minusp, eval, apply,   *)
    (* evlis, prin1, print, prin2t, list2 ... list5.   *)

FUNCTION Setq(VAR u: any; v: any): any;
    BEGIN   (* setq *)
    (* should check to make sure u not t or nil. *)
    u := v;
    Setq := v
    END  (* setq *);

FUNCTION Atom(item : any): any;
    BEGIN       (* atom *)
    IF Tag_of(item) <> pairtag THEN Atom := t
    ELSE Atom := xnil
    END (* atom *);

FUNCTION Codep(item: any): any;
    BEGIN       (* codep *)
    IF Tag_of(item) = codetag THEN Codep := t
    ELSE Codep := xnil
    END (* codep *);

FUNCTION Idp(item: any): any;
    BEGIN       (* idp *)
    IF Tag_of(item) = idtag THEN Idp := t
    ELSE Idp := xnil
    END (* idp *);

FUNCTION Pairp(*item: any): any*);
    BEGIN (* pairp *)
    IF Tag_of(item) = pairtag THEN Pairp := t
    ELSE Pairp := xnil
    END (* pairp *);

FUNCTION Constantp(item: any): any;
    BEGIN       (* constantp *)
    IF NOT((Pairp(item) = t) OR (Idp(item) = t)) THEN
	Constantp := t
    ELSE Constantp := xnil
    END (* constantp *);

FUNCTION Eq(u, v: any): any;
    BEGIN       (* eq *)
    IF u = v THEN Eq := t
    ELSE Eq := xnil
    END (* eq *);

FUNCTION Eqn(u, v: any): any;
    VAR i, j: longint;

    BEGIN       (* eqn *)
    Int_val(u, i);
    Int_val(v, j);
    IF i = j THEN Eqn := t
    ELSE Eqn := xnil
    END (* eqn *);

FUNCTION Fixp(item: any): any;
    BEGIN       (* fixp *)
    IF (Tag_of(item) = inttag) OR (Tag_of(item) = fixtag) THEN
	Fixp := t
    ELSE Fixp := xnil
    END (* fixp *);

FUNCTION Floatp(item: any): any;
    BEGIN       (* floatp *)
    IF Tag_of(item) = flotag THEN Floatp := t
    ELSE Floatp := xnil
    END (* floatp *);

FUNCTION Numberp(item: any): any;
    BEGIN       (* numberp *)
    Numberp := Fixp(item)   (* will have to fix for floats *)
    END (* numberp *);

FUNCTION Cons(u, v: any): any;
    VAR p: integer;

    BEGIN   (* cons *)
    (* push args onto stack, in case we need to garbage collect the *)
    (* references will be detected.                                 *)
    Alloc(2);
    stk[st] := u;
    stk[st-1] := v;

    IF prspace[freepair].prcdr = xnil THEN Gcollect;

    p := freepair;
    freepair := Info_of(prspace[p].prcdr);
    prspace[p].prcar := u;
    prspace[p].prcdr := v;
    Cons := Mkpair(p);       (* return new pair. *)

    consknt := consknt + 1;
    Dealloc(2);
    END     (* cons *);

FUNCTION Ncons(u: any): any;
    BEGIN
    Ncons := Cons(u, xnil)
    END;

FUNCTION Xcons(u, v: any): any;
    BEGIN
    Xcons := Cons(v, u)
    END;

FUNCTION Car(*u: any): any*);
    BEGIN
    IF Tag_of(u) = pairtag THEN
	Car := prspace[Info_of(u)].prcar
    ELSE
	Car := Mkitem(errtag, notpair);
    END;

FUNCTION Cdr(*u: any): any*);
    BEGIN
    IF Tag_of(u) = pairtag THEN
	Cdr := prspace[Info_of(u)].prcdr
    ELSE
	Cdr := Mkitem(errtag, notpair);
    END;


    (* fluid binding *)
FUNCTION Push_bind(bind: any): any;
    BEGIN	(* push_bind *)
    old_binds := cons(bind, old_binds);
    push_bind := xnil
    END	(* push_bind *);

FUNCTION Lam_bind(alist: any): any;
    VAR bind: any;

    BEGIN (* lam_bind *)
    WHILE Truep(Pairp(alist)) DO
	BEGIN
	bind := Car(alist);
	alist := Cdr(alist);
	push_bind(bind);
	setvalue(Car(bind), Cdr(bind))
	END;
    Lam_bind := xnil
    END  (* lam_bind *);

FUNCTION Prog_bind(id: any): any;
    BEGIN (* prog_bind *)
    Prog_bind := Lam_bind(cons(id, xnil))
    END (* prog_bind *);

FUNCTION Unbind(id: any): any;
    BEGIN (* unbind *)
    setvalue(id, cdr(atsoc(id, old_binds)))
    Unbind := xnil
    END (* unbind *);

    (* arithmetic functions *)
FUNCTION Add1(i: any): any;
    VAR j: longint;

    BEGIN
    Int_val(i, j);
    Add1 := Mkint(j + 1)
    END;

FUNCTION Difference(i, j: any): any;
    VAR i1, i2: longint;

    BEGIN
    Int_val(i, i1);
    Int_val(j, i2);
    Difference := Mkint(i1 - i2)
    END;

FUNCTION Divide(i, j: any): any;
    (* returns dotted pair (quotient . remainder). *)
    VAR i1, i2: longint;

    BEGIN
    Int_val(i, i1);
    Int_val(j, i2);
    IF i2 = 0 THEN Writeln('***** ATTEMPT TO DIVIDE BY 0 IN DIVIDE');
    Divide := Cons(Mkint(i1 DIV i2), Mkint(i1 MOD i2))
    END;

FUNCTION Greaterp(i, j: any): any;
    VAR i1, i2: longint;

    BEGIN
    Int_val(i, i1);
    Int_val(j, i2);

    IF i1 > i2 THEN
	Greaterp := t
    ELSE
	Greaterp := xnil;
    END;

FUNCTION Lessp(i, j: any): any;
    VAR i1, i2: longint;

    BEGIN
    Int_val(i, i1);
    Int_val(j, i2);

    IF i1 < i2 THEN
	Lessp := t
    ELSE
	Lessp := xnil;
    END;

FUNCTION Minus(i: any): any;
    VAR j: longint;

    BEGIN
    Int_val(i, j);
    Minus := Mkint(-j)
    END;

FUNCTION Plus2(i, j: any): any;
    VAR i1, i2: longint;

    BEGIN
    Int_val(i, i1);
    Int_val(j, i2);
    Plus2 := Mkint(i1 + i2)
    END;

FUNCTION Quotient(i, j: any): any;
    VAR i1, i2: longint;

    BEGIN
    Int_val(i, i1);
    Int_val(j, i2);
    IF i2 = 0 THEN Writeln('***** ATTEMPT TO DIVIDE BY 0 IN QUOTIENT');
    Quotient := Mkint(i1 DIV i2)
    END;

FUNCTION Remainder(i, j: any): any;
    VAR i1, i2: longint;

    BEGIN
    Int_val(i, i1);
    Int_val(j, i2);
    IF i2 = 0 THEN Writeln('***** ATTEMPT TO DIVIDE BY 0 IN REMAINDER');
    Remainder := Mkint(i1 MOD i2)
    END;

FUNCTION Times2(i, j: any): any;
    VAR i1, i2: longint;

    BEGIN
    Int_val(i, i1);
    Int_val(j, i2);
    Times2 := Mkint(i1 * i2)
    END;
    (* times2 *)

    (* symbol table support *)
FUNCTION Value(u: any): any;
    BEGIN   (* value *)
    Value := idspace[Info_of(u)].val
    END     (* value *);

FUNCTION Plist(u: any): any;
    BEGIN   (* plist *)
    Plist := idspace[Info_of(u)].plist
    END     (* plist *);

FUNCTION Funcell(u: any): any;
    BEGIN   (* funcell *)
    Funcell := idspace[Info_of(u)].funcell
    END     (* funcell *);

FUNCTION Setplist(u, v: any): any;
    BEGIN (* setplist *)
    END (* setplist *);

    (* also need setvalue, setfuncell, setplist. *)

FUNCTION Xnot(u: any): any;
    BEGIN (* xnot *)
    Xnot := Eq(u, xnil)
    END (* xnot *);


    (********************************************************)
    (*                                                      *)
    (*                    i/o primitives                    *)
    (*                                                      *)
    (********************************************************)


PROCEDURE Terpri;
    (* need to change for multiple output channels.  *)
    BEGIN
    Writeln(output);
    END;


PROCEDURE Wrtok(u: any);
    (* doesn't expand escaped characters in identifier names *)
    VAR i: integer;
    BEGIN
    IF Tag_of(u) = inttag THEN
	IF Info_of(u) = 0 THEN
	    Write('0')
	ELSE
	    Write(Info_of(u): 2+Trunc(Log(Abs(Info_of(u)))))

    ELSE IF Tag_of(u) = fixtag THEN
	Write(intspace[Info_of(u)])

    ELSE IF Tag_of(u) = flotag THEN
	Write(flospace[Info_of(u)])

    ELSE IF Tag_of(u) = idtag THEN
	BEGIN
	i := idspace[Info_of(u)].idname;
	WHILE (i <= maxstrsp) AND (strspace[i] <> Chr(eos)) DO
	    BEGIN
	    Write(strspace[i]);
	    i:= i + 1;
	    END;
	END

    ELSE IF Tag_of(u) = chartag THEN
	Write(Chr(Info_of(u) - choffset))

    ELSE
	Writeln('WRTOK GIVEN ',Tag_of(u), Info_of(u));
    END;


PROCEDURE Rdchnl(chnlnum: integer; VAR ch: onechar);
    BEGIN
    IF (chnlnum < 1) OR (chnlnum > inchns) THEN
	Writeln('*****BAD INPUT CHANNEL FOR RDCHNL')
    ELSE
	CASE chnlnum OF
	    1:  BEGIN
		ch := symin^;  (* a little strange, but avoids  *)
		Get(symin);              (* initialization problems *)
		ichrbuf[inchnl] := symin^;
		END;

	    2:  BEGIN
		ch := input^;
		Get(input);
		ichrbuf[inchnl] := input^;
		END;
		END;
    (* case *)
    END;
    (* rdchnl *)

FUNCTION Eofchnl(chnlnum: integer): boolean;
    BEGIN
    IF (chnlnum < 1) OR (chnlnum > inchns) THEN
	Writeln('*****BAD INPUT CHANNEL FOR EOFCHNL')
    ELSE
	CASE chnlnum OF
	    1:  Eofchnl := Eof(symin);
	    2:  Eofchnl := Eof(input);
		END;
    END;

    (********************************************************)
    (*                                                      *)
    (*                   token scanner                      *)
    (*                                                      *)
    (********************************************************)

FUNCTION Rdtok: any;
    VAR
	ch: onechar;
	i: integer;
	anint: longint;
	moreid: boolean;
	found: boolean;
	token: any; (* the token read *)

    FUNCTION Digit(ch: onechar): boolean;
	BEGIN
	Digit := ( '0' <= ch ) AND ( ch <= '9')
	END;

    FUNCTION Escalpha(VAR ch: onechar): boolean;
	(* test for alphabetic or escaped character.  *)
	(* note possible side effect.                 *)
	BEGIN   (* escalpha *)
	IF ( 'A' <= ch ) AND ( ch <= 'Z') THEN
	    Escalpha := true
	ELSE IF ( Ord('A')+32 <= Ord(ch)) AND ( Ord(ch) <= Ord('Z')+32) THEN
	    Escalpha := true    (* lower case alphabetics *)
	ELSE IF ch='!' THEN
	    BEGIN
	    Rdchnl(inchnl,ch);
	    Escalpha := true;
	    END
	ELSE
	    Escalpha := false;
	END     (* escalpha *);

    FUNCTION Alphanum(VAR ch: onechar): boolean;
	(* test if escalfa or digit *)
	VAR b: boolean;
	BEGIN
	b := Digit(ch);
	IF NOT b THEN b := Escalpha(ch);
	Alphanum := b;
	END;

    FUNCTION Whitesp(ch: onechar): boolean;
	BEGIN
	(* may want a faster test *)
	Whitesp := (ch = sp) OR (Ord(ch) = cr) OR (Ord(ch) = lf)
	OR (Ord(ch) = ht) OR (Ord(ch) = nul)
	END;


	(* reads fixnums...need to read flonums too *)
    BEGIN       (* rdtok *)
    IF NOT Eofchnl(inchnl) THEN
	REPEAT                          (* skip leading white space. *)
	    Rdchnl(inchnl,ch)
	UNTIL (NOT Whitesp(ch)) OR Eofchnl(inchnl);
    IF Eofchnl(inchnl) THEN
	token := Mkitem(chartag, eofcode + choffset)
	(* should really return !$eof!$  *)

    ELSE
	BEGIN
	token := xnil;        (* init to something *)

	IF Digit(ch) THEN
	    Set_tag(token, inttag)
	ELSE IF Escalpha(ch) THEN
	    Set_tag(token, idtag)
	ELSE
	    Set_tag(token, chartag);

	CASE Tag_of(token) OF
	    chartag:  BEGIN
		Set_tag(token, idtag);
		idspace[toktype].val := Mkitem(inttag, chartype);
		Set_info(token, Ord(ch) + choffset);
		END;
	    inttag:   BEGIN
		idspace[toktype].val := Mkitem(inttag, inttype);
		anint := Ord(ch) - Ord('0');
		WHILE Digit(ichrbuf[inchnl]) DO
		    BEGIN
		    Rdchnl(inchnl,ch);
		    anint := 10 * anint + (Ord(ch) - Ord('0'))
		    END;
		Set_info(token, anint)
		END;

	    idtag:    BEGIN
		idspace[toktype].val := Mkitem(inttag, idtype);
		i := freestr; (* point to possible new string *)
		moreid := true;
		WHILE (i < maxstrsp) AND moreid DO
		    BEGIN
		    strspace[i] := ch;
		    i := i + 1;
		    moreid := Alphanum(ichrbuf[inchnl]);
		    IF moreid THEN
			Rdchnl(inchnl,ch);
		    END;
		strspace[i] := Chr(eos);   (* terminate string *)
		IF (i >= maxstrsp) THEN
		    Writeln('*****STRING SPACE EXHAUSTED')
		ELSE  (* look the name up, return item for it *)
		    BEGIN
		    Putnm(freestr, token, found);
		    IF NOT found THEN
			freestr := i + 1;
		    END;
		END;
		(* of case idtag *)
	END;
	(* of case *)
	END;
    Rdtok := token
    END;
    (* rdtok *)

    (********************************************************)
    (*                                                      *)
    (*                    initialization                    *)
    (*                                                      *)
    (********************************************************)

FUNCTION Read: any;    FORWARD;

PROCEDURE Init;
    (* initialization procedure depends on  *)
    (* ability to load stack with constants *)
    (* from a file.                         *)
    VAR
	strptr: stringp;
	nam: PACKED ARRAY[1..3] OF onechar;
	(* holds 'nil', other strings? *)
	i, n: integer;
	idref: any;
	found: boolean;

	(* init is divided into two parts so it can compile on terak *)
    PROCEDURE Init1;
	BEGIN
	(* initialize top of stack *)
	st := 0;

	freefloat := 1;

	(* define nil - the id, nil, is defined a little later. *)
	freeident := 1;
	xnil := Mkitem(idtag, freeident);

	(* initialize pair space. *)
	FOR i := 1 TO maxpair - 1 DO      (* initialize free list. *)
	    BEGIN
	    prspace[i].markflg := false;        (* redundant? *)
	    prspace[i].prcar := xnil;         (* just for fun *)
	    prspace[i].prcdr := Mkitem(pairtag, i + 1)
	    END;
	prspace[maxpair].prcar := xnil;
	prspace[maxpair].prcdr := xnil;       (* end flag *)
	freepair := 1;                  (* point to first free pair *)


	(* initialize identifier space and string space. *)
	freestr := 1;
	FOR i := 0 TO hidmax - 1 DO
	    idhead[i] := nillnk;
	FOR i := 1 TO maxident DO
	    BEGIN
	    IF i < maxident THEN
		idspace[i].idhlink := i + 1
	    ELSE    (* nil to mark the final identifier in the table. *)
		idspace[i].idhlink := nillnk;
	    (* set function cells to undefined *)
	    idspace[i].funcell := Mkitem(errtag, undefined)
	    END;

	(* nil must be the first identifier in the table--id #1 *)
	(* must fill in fields by hand for nil.*)
	(* putnm can handle any later additions.  *)
	nam := 'NIL';
	strptr := freestr;
	FOR i := 1 TO 3 DO
	    BEGIN
	    strspace[strptr] := nam[i];
	    strptr:= strptr + 1;
	    END;
	strspace[strptr] := Chr(eos);
	Putnm(freestr, xnil, found);
	IF NOT found THEN
	    freestr := strptr + 1;

	(* make the single character ascii identifiers, except nul(=eos). *)
	FOR i := 1 TO 127  DO
	    BEGIN
	    strspace[freestr] := Chr(i);
	    strspace[freestr + 1] := Chr(eos);
	    Putnm(freestr, idref, found);
	    IF NOT found THEN
		freestr := freestr + 2;
	    IF i = Ord('T') THEN
		t := idref;
	    (* returns location for 't. *)
	    END;

	(* init fixnum free list. *)
	FOR i := 1 TO maxintsp - 1 DO
	    intspace[i] := i + 1;
	intspace[maxintsp] := end_flag;
	freeint := 1;


	(* clear the counters *)
	gccount := 0;
	consknt := 0;
	pairknt := 0;
	END     (* init1 *);


    PROCEDURE Init2;
	VAR token: any;

	BEGIN
	(* load "symbol table" with identifiers, constants, and functions.  *)
	inchnl := 1;        (* select symbol input file. *)
	(* reset(symin,'#5:poly.data'); *) (* for terak *)


	token := Rdtok;     (* get count of identifiers. *)
	IF Tag_of(token) <> inttag THEN
	    Writeln('*****BAD SYMBOL TABLE, INTEGER EXPECTED AT START');
	n := Info_of(token);
	FOR i := 1 TO n DO
	    token := Rdtok;
	(* reading token magically loads it into id space. *)
	token := Rdtok;         (* look for zero terminator. *)
	IF (Tag_of(token) <> inttag) OR (Info_of(token) <> 0) THEN
	    Writeln('*****BAD SYMBOL TABLE, ZERO EXPECTED AFTER IDENTIFIERS');

	token := Rdtok;         (* count of constants  *)
	IF Tag_of(token) <> inttag THEN
	    Writeln('*****BAD SYMBOL TABLE, INTEGER EXPECTED BEFORE CONSTANTS');
	n := Info_of(token);
	Alloc(n);       (* space for constants on the stack *)
	FOR i := 1 TO n DO
	    stk[i] := Read;
	token := Rdtok;
	IF (Tag_of(token) <> inttag) OR (Info_of(token) <> 0) THEN
	    Writeln('*****BAD SYMBOL TABLE, ZERO EXPECTED AFTER CONSTANTS');


	token := Rdtok;     (* count of functions. *)
	IF Tag_of(token) <> inttag THEN
	    Writeln('*****BAD SYMBOL TABLE, INTEGER EXPECTED BEFORE FUNCTIONS');
	n := Info_of(token);
	FOR i := 1 TO n DO
	    (* for each function *)
	    (* store associated code *)
	    idspace[Rdtok].funcell := Mkitem(codetag, i);
	token := Rdtok;
	IF (Tag_of(token) <> inttag) OR (Info_of(token) <> 0) THEN
	    Writeln('*****BAD SYMBOL TABLE, ZERO EXPECTED AFTER FUNCTIONS');

	inchnl := 2;        (* select standard input. *)
	END     (* init2 *);

    BEGIN       (* init *)
    Init1;
    Init2;
    END    (* init *);


    (********************************************************)
    (*                                                      *)
    (*                        apply                         *)
    (*                                                      *)
    (********************************************************)

FUNCTION Apply(fn, arglist: any): any;
    VAR arg1, arg2, arg3, arg4, arg5: any;
	numargs: integer;

    BEGIN (* apply *)
    IF Tag_of(fn) <> codetag THEN
	Writeln('*****APPLY: UNDEFINED FUNCTION.')
    ELSE
	BEGIN   (* spread the arguments *)
	numargs := 0;
	WHILE Truep(Pairp(arglist)) DO
	    BEGIN
	    numargs := numargs + 1;
	    CASE numargs OF
		1: arg1 := Car(arglist);
		2: arg2 := Car(arglist);
		3: arg3 := Car(arglist);
		4: arg4 := Car(arglist);
		5: arg5 := Car(arglist);
		6: Writeln('APPLY: TOO MANY ARGS SUPPLIED.')
		END (* case *);
	    arglist := Cdr(arglist)
	    END (* while *)
	END (* if *);

    CASE Info_of(fn) OF
	1: Apply := Atom(arg1);
	END (* case *)
    END (* apply *);
    (*??* Missing closing point at end of program. *??*)
(*??* Missing closing point at end of program. *??*)

 (* PreProcessor Version - Run  through Filter *)
      (* PERQ version *)
(*%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%                                     
% 		PASCAL BASED MINI-LISP
%
% File: 	PAS0.PAS - PASCAL/LISP KERNEL
% ChangeDate: 	11:00pm Monday, 28 September 1981
% By: 		Ralph Ottenheimer big -> fix, END comment FOR #pta
%		COMPRESS & EXPLODE
% 
% 	    All RIGHTS RESERVED
%           COPYRIGHT (C) - 1981 - M. L. GRISS
%           Computer Science Department
%           University of Utah
%
%           Do Not distribute with out written consent of M. L. Griss
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%*)


    PROGRAM pas0 (input,output, symin,finput,foutput);
    (************************************************************)
    (* support routines for a "lisp" machine.  uses a register  *)
    (* model with a stack for holding frames.  stack also used  *)
    (* to hold compiler generated constants.                    *)
    (* written by william f. galway and martin l. griss         *)
    (* modified by ralph ottenheimer may 81                     *)
    (* append pas1...pasn at  end                               *)
    (* -------------------------------------------------------- *)
    (* symin is input channel one--used to initialize "symbol   *)
    (* table".  input is input channel two--standard input.     *)
    (* output is output channel one--the standard output.       *)
    (* finput is file input channel three.                      *)
    (* foutput is file output channel four.                      *)
    (************************************************************)


imports Stream from Stream;
imports system from system;
imports io_others from io_others;
imports io_unit from io_unit;


CONST
    (* for terak, perq, Apollo, vax  *)
 sp = ' '; 
 ht = 9;          (* ascii codes *)
 lf = 10;
 cr = 13; 
 nul = 0;

   eos = chr(0);        (* KLUDGE: null string *)
    inchns = 3;       (* number of input channels.  *)
    outchns = 4;      (* number of output channels. *)
    begin_comment = '%';

(* Initial symbols, needed in Kernel *)
    xtoktype  =  129; (* slot in idspace for toktype. *)
    xbstack   = 130;  (* Bstack Pointer *)
    xthrowing = 131;  (* If throw mode *)
    xinitform = 132;  (* for restart *)
    xraise    = 133;  (* for RAISE of lc in ids *)

    chartype  =  3;   (* various token types *)
    inttype  =  1;
    idtype  =  2;

   (* no shift const *)
    (* assumed to be at least 16 bits long.  low order 13 bits  *)
    (* are the info, top 3 are the tag.                         *)
     int_offset = 32767; (* PERQ item is record *   )

    (* the various tags - can't use a defined scalar type *)
    (* because of the lack of convertion functions.       *)
    inttag = 0;    (* info is an integer                  *)
    chartag = 1;   (* info is a character code            *)
    pairtag = 2;   (* info points to pair                 *)
    idtag = 3;     (* info points to identifier           *)
    codetag = 4;   (* info is index into a case statement *)
    (*                that calls appropriate function.    *)
    errtag = 5;    (* info is an error code - see below.  *)
    fixtag = 6;    (* info points to a full word (or      *)
    (*                longer) integer.                    *)
    flotag = 7;    (* info points to a float number.      *)

    (* error codes.  corresponding to tag = errtag.  *)
    noprspace = 1;    (* no more "pair space"--can't cons. *)
    notpair = 2;      (* a pair operation attempted on a non-pair. *)
    noidspace = 3;    (* no more free identifiers *)
    undefined = 4;    (* used to mark undefined function cells (etc?) *)

    maxpair = 3700;   (* max number of pairs allowed. *)
    maxident = 800;   (* max number of identifiers *)
    maxstrsp = 4500;  (* size of string (literal) storage space. *)
    maxintsp = 200;   (* max number of long integers allowed *)
     maxflosp = 50;     (* max number of floating numbers allowed *)

    hidmax = 50;      (* number of hash values for identifiers *)
    maxgcstk = 100;   (* size of garbage collection stack.    *)
    stksize = 500;    (* stack size *)
    maxreg = 15;      (* number of registers in lisp machine. *)

    eofcode = 26;     (* magic character code for eof, ascii for *)
    (*  cntrl-z.  kludge, see note in xrdtok.  *)
    choffset = 1;     (* add choffset to ascii code to get address  *)
    (* in id space for corresponding identifier.  *)
    nillnk = 0;       (* when integers are used as pointers.  *)


TYPE
    onechar = char;     (* for terak,perq,Apollo*)

    (* note we allow zero for id_ptr, allowing a "nil" link. *)

    stringp = 1..maxstrsp;        (* pointer into string space. *)
    id_ptr = 0..maxident;            (* pointer into id space. *)

       itemref = RECORD
	           tag:integer;
                 info:integer;
                 END;
    itemtype = 0..7;    (* the tags *)


    pair = PACKED RECORD
		      prcar: itemref;
		      prcdr: itemref;
	(* OLD        markflag:boolean , but wastes space *)
		  END;


   ascfile = PACKED FILE OF onechar;

    ident = PACKED RECORD           (* identifier *)
		       idname: stringp;
		       val: itemref;       (* value *)
		       plist: itemref;     (* property list *)
		       funcell: itemref;   (* function cell *)
		       idhlink: id_ptr;    (* hash link *)
		   END;
    longint = integer;
VAR
    (* global information *)
    nilref,trueref: itemref;    (* refers to identifiers "nil", and "t". *)
    initphase: integer;                (* Start up *)
    r: ARRAY[1..maxreg] OF itemref;
    rxx,ryy: itemref;



    (* "st" is the stack pointer into "stk".  it counts the number of  *)
    (* items on the stack, so it runs from zero while the stack starts *)
    (* at one.                                                         *)
    st: 0..stksize;
    stk: ARRAY[1..stksize] OF itemref;

    (* pair space *)
    prspace: PACKED ARRAY[1..maxpair] OF pair; (* all pairs stored here. *)
    freepair: integer;          (* pointer to next free pair in prspace. *)

    (* identifier space *)
    idhead: ARRAY[0..hidmax] OF id_ptr;
    idspace: PACKED ARRAY[1..maxident] OF ident;
    freeident: integer;

    (* string space *)
    strspace: PACKED ARRAY[1..maxstrsp] OF onechar;
    freestr: stringp;

    (* large integer space *)
    intspace: ARRAY[1..maxintsp] OF longint;    (* use long int on terak *)
    freeint: 1..maxintsp;

    (* floating point number space *)
    flospace: ARRAY[1..maxflosp] OF real;
    freefloat: 1..maxflosp;

    (* i/o channels *)
  (* files declared on header *)
    symin : ascfile;
    finput : ascfile;
    foutput : ascfile;
    inchnl: 1..inchns;      (* current input channel number  *)
    outchnl: 1..outchns;    (* current output channel number *)

    (* "current character" for each input channel.                    *)
    (* may want to include more than one character at some later date *)
    (* (for more lookahead).                                          *)
    ichrbuf: ARRAY[1..inchns] OF onechar;

    (* for collecting statistics. *)
    gccount: integer;           (* counts garbage collections *)
    (* counts from last garbage collection. *)
    consknt: integer;           (* number of times "cons" called *)



(* ........ Everything nested inside CATCH *)

Procedure Xcatch;  (* ----------- Outermost Procedure ----------- *)
 var catch_stk:0..stksize;
     catch_Bstk:itemref;

PROCEDURE xread;
    FORWARD;

PROCEDURE xprint;
    FORWARD;

PROCEDURE xunbindto;
    FORWARD;

PROCEDURE xeval;
    FORWARD;

 Procedure Xthrow;
    begin (* throw value *)
        idspace[Xthrowing].val := trueref;
      exit(xeval)
    end (* throw *);
    
 Handler CtlC;  (* ------- handle runaway aborts ------- *)
 
 begin
    write('^C');
    IOKeyClear;
    IObeep;
    if initphase > 1 then Xthrow;
 end;

    (********************************************************)
    (*                                                      *)
    (*             item selectors & constructors            *)
    (*                                                      *)
    (********************************************************)


FUNCTION tag_of(item: itemref): itemtype;

    BEGIN (* tag_of *)
       tag_of := item.tag;
    END;
    (* tag_of *)

FUNCTION info_of(item: itemref): integer;

 BEGIN (* info_of *)
      info_of := item.info
    END;
    (* info_of *)

PROCEDURE mkitem(tag: itemtype; info: longint; VAR item: itemref);
    (* do range checking on info. ints run from -4096 to +4095 *)
    (* everything else runs from 0 to 8191. ints & chars       *)
    (* contain their info, all others points into an           *)
    (* appropriate space.                                      *)

    PROCEDURE mkfixint;
	BEGIN (* mkfixint *)
	IF freeint < maxintsp THEN     (* convert to fixnum *)
	    BEGIN
	    tag := fixtag;
	    intspace[freeint] := info;
	    info := freeint;        (* since we want the pointer *)
	    freeint := freeint + 1;
	    END
	ELSE BEGIN
                 writeln('*****FIXNUM SPACE EXHAUSTED');
                 (* should do gc *)
		 exit(pas0);
             END;
	END;
	(* mkfixint *)


    BEGIN (* mkitem *)
    IF tag = inttag THEN
      BEGIN
	IF (info < -int_offset) OR (info > int_offset - 1) THEN mkfixint
 	END
    ELSE IF tag = fixtag THEN mkfixint

	 ELSE IF info < 0 THEN
		  BEGIN
		  writeln('*****MKITEM: BAD NEG');
                exit(pas0);
		  END;
    (* nothing special to do for other types *)

    (* pack tag and info into 16-bit item.   *)
       item.tag := tag;
       item.info := info
    END;
    (* mkitem *)

PROCEDURE set_info(VAR item: itemref; newinfo: longint);
    BEGIN (* set_info *)
    mkitem(tag_of(item), newinfo, item)
    END;
    (* set_info *)

PROCEDURE set_tag(VAR item: itemref; newtag: itemtype);
    BEGIN (* set_tag *)
    mkitem(newtag, info_of(item), item)
    END;
    (* set_tag *)

PROCEDURE mkident(id: integer; reg: integer);
    (* make identifier "id" in register "reg" *)
    BEGIN       (* mkident *)
    mkitem(idtag, id, r[reg]);
    END;
    (* mkident *)

PROCEDURE mkint(int: longint; reg: integer);
    BEGIN       (* mkint *)
    mkitem(inttag, int, r[reg]);
    END;
    (* mkint *)

PROCEDURE mkpair(pr: integer; reg: integer);
    BEGIN (* mkpair *)
    mkitem(pairtag, pr, r[reg])
    END;
    (* mkpair *)

PROCEDURE int_val(item: itemref; VAR number: longint);
    (* returns integer value of item (int or fixnum). *)
    (* must return 'number' in var parameter instead  *)
    (* of function value since long integers are not  *)
    (* a legal function type in ucsd pascal.          *)
    BEGIN (* int_val *)
    IF tag_of(item) = inttag THEN
	number := info_of(item)
    ELSE IF tag_of(item) = fixtag THEN
	     number := intspace[info_of(item)]
  ELSE writeln('***** ILLEGAL DATA TYPE FOR NUMERIC OPERATION')
	(* halt or fatal error *)
    END;
    (* int_val *)


    (********************************************************)
    (*                                                      *)
    (*                  stack allocation                    *)
    (*                                                      *)
    (********************************************************)

PROCEDURE alloc(n: integer);
    BEGIN
    IF n + st <= stksize THEN
	st := n+st
    ELSE
	BEGIN
   writeln('*****LISP STACK OVERFLOW');
	writeln('     TRIED TO ALLOCATE ',n);
	writeln('     CURRENT STACK TOP IS ',st);
	END;
    END;

PROCEDURE dealloc(n: integer);
    BEGIN
    IF st - n >= 0 THEN
	st := st - n
    ELSE
	writeln('*****LISP STACK UNDERFLOW');
    END;

    (* optimized allocs *)

PROCEDURE alloc1;
    BEGIN alloc(1) END;

PROCEDURE dealloc1;
    BEGIN dealloc(1) END;

PROCEDURE alloc2;
    BEGIN alloc(2) END;

PROCEDURE dealloc2;
    BEGIN dealloc(2) END;

PROCEDURE alloc3;
    BEGIN alloc(3) END;

PROCEDURE dealloc3;
    BEGIN dealloc(3) END;


    (********************************************************)
    (*                                                      *)
    (*              support for register model              *)
    (*                                                      *)
    (********************************************************)

PROCEDURE load(reg: integer; sloc: integer);
    BEGIN
    IF sloc < 0 THEN r[reg] := r[-sloc]
    ELSE  r[reg] := stk[st-sloc];
    (* will, fix for load (pos,pos) *)
    END;

PROCEDURE store(reg: integer; sloc: integer);
    BEGIN
    stk[st-sloc] := r[reg];
    END;

    (* optimized load/store. *)
PROCEDURE load10;
    BEGIN
    load(1,0);
    END;

PROCEDURE store10;
    BEGIN
    store(1,0);
    END;

PROCEDURE storenil(sloc: integer);
    BEGIN
    stk[st-sloc] := nilref;
    END;

(* Other primitives ?? *)

    (********************************************************)
    (*                                                      *)
    (*              identifier lookup & entry               *)
    (*                                                      *)
    (********************************************************)

function nmhash(nm: stringp): integer;
    CONST
	hashc = 256;
    VAR
	i,tmp: integer;
    BEGIN
    tmp := 0;
    i := 1;     (* get hash code from first three chars of string. *)
    WHILE (i <= 3) AND (strspace[nm+i] <> eos) DO
	BEGIN
	tmp := ord(strspace[nm+i]) + hashc*tmp;
	i := i + 1;
	END;
    nmhash := abs(tmp) MOD hidmax;      (* abs because mod is screwy. *)
    END;

FUNCTION eqstr(s1,s2: stringp): boolean;
    BEGIN
    WHILE (strspace[s1] = strspace[s2]) AND (strspace[s1] <> eos) DO
	BEGIN
	s1 := s1 + 1;
	s2 := s2 + 1;
	END;
    eqstr := (strspace[s1] = strspace[s2]);
    END;

PROCEDURE nmlookup(nm: stringp; VAR found: boolean; VAR hash: integer;
		   VAR loc: itemref);
    (* lookup a name in "identifier space".                                 *)
    (* "hash" returns the hash value for the name.                          *)
    (* "loc" returns the location in the space for the (possibly new)       *)
    (* identifier.                                                          *)
    BEGIN
    hash := nmhash(nm);
    mkitem(idtag, idhead[hash], loc);
    (* default is identifier, but may be "error". *)
    (* start at appropriate hash chain. *)

    found := false;
    WHILE (info_of(loc) <> nillnk) AND (NOT found) DO
	BEGIN
	found := eqstr(nm, idspace[info_of(loc)].idname);
	IF NOT found THEN
	    set_info(loc, idspace[info_of(loc)].idhlink);
	(* next id in chain *)
	END;
    IF NOT found THEN               (* find spot for new identifier *)
	BEGIN
	IF freeident=nillnk THEN    (* no more free identifiers. *)
	    mkitem(errtag, noidspace, loc)
	ELSE
	    BEGIN
	    set_info(loc, freeident);
	    freeident := idspace[freeident].idhlink;
	    END;
	END;
    END;

PROCEDURE putnm(nm: stringp; VAR z: itemref; VAR found: boolean);
    (* put a new name into identifier space, or return old location *)
    (* if it's already there.                                       *)
    VAR
	tmp: ident;
	hash: integer;
    BEGIN
    nmlookup(nm, found, hash, z);
    IF (NOT found) AND (tag_of(z) = idtag) THEN
	BEGIN
	tmp.idname := nm;
	tmp.idhlink := idhead[hash];   (* put new ident at head of chain     *)
	tmp.val := nilref;             (* initialize value and property list *)
	tmp.plist := nilref;
	tmp.funcell := nilref;         (* also, the function cell *)
	idhead[hash] := info_of(z);
	idspace[info_of(z)] := tmp;
	END;
    END;

PROCEDURE xfaststat;
    (* give quick summary of statistics gathered *)
    BEGIN
    writeln('CONSES:',consknt);
    writeln('ST    :',st);
    END;


    (********************************************************)
    (*                                                      *)
    (*              the garbage collector                   *)
    (*                                                      *)
    (********************************************************)

PROCEDURE xgcollect;
    VAR
	i: integer;
	markedk: integer;   (* counts the number of pairs marked *)
	freedk: integer;    (* counts the number of pairs freed. *)
	gcstkp: 0..maxgcstk; (* note the garbage collection stack   *)
	mxgcstk: 0..maxgcstk;           (* is local to this procedure. *)
	gcstk: ARRAY[1..maxgcstk] OF integer;
        markflag: PACKED ARRAY[1..maxpair] OF boolean;
(* used not to have array here *)
        
    PROCEDURE pushref(pr: itemref);
	(* push the address of an unmarked pair, if that's what it is. *)
	BEGIN
	IF tag_of(pr) = pairtag THEN
	    IF NOT markflag[info_of(pr)] THEN  (* was .markflag *)
		BEGIN
		IF gcstkp < maxgcstk THEN
		    BEGIN
		    gcstkp := gcstkp + 1;
		    gcstk[gcstkp] := info_of(pr);
		    IF gcstkp > mxgcstk THEN
			mxgcstk := gcstkp;
		    END
		ELSE
		    BEGIN
		    writeln('*****GARBAGE STACK OVERFLOW');
                  exit(pas0);
		    END;
		END;
	END;

    PROCEDURE mark;
	(* "recursively" mark pairs referred to from gcstk. gcstk is used to *)
	(* simulate recursion.                                               *)
	VAR
	    prloc: integer;
	BEGIN
	WHILE gcstkp > 0 DO
	    BEGIN
	    prloc := gcstk[gcstkp];
	    gcstkp := gcstkp - 1;
            markflag[prloc] := true;
(* OLD      prspace[prloc].markflag := true;  *)
	    pushref(prspace[prloc].prcdr);
	    pushref(prspace[prloc].prcar);  (* trace the car first. *)
	    END;
	END;

    BEGIN       (* xgcollect *)
    writeln('***GARBAGE COLLECTOR CALLED');
    gccount := gccount + 1;          (* count garbage collections. *)
    xfaststat;   (* give summary of statistics collected *)
    consknt := 0;       (* clear out the cons counter *)
    gcstkp := 0;        (* initialize the garbage stack pointer. *)
    mxgcstk := 0;       (* keeps track of max stack depth. *)

    (* clear markflags *)
    FOR i := 1 TO maxpair DO markflag[i] := false;
    (* OLD: wasnt needed *)
    (* mark things from the "computation" stack. *)
    FOR i := 1 TO st DO
	BEGIN
	pushref(stk[i]);
	mark;
	END;
    (* mark things from identifier space. *)
    FOR i := 1 TO maxident DO
	BEGIN
	pushref(idspace[i].val);
	mark;
	pushref(idspace[i].plist);
	mark;
	pushref(idspace[i].funcell);
	mark;
	END;

    (* reconstruct free list by adding things to the head. *)
    freedk := 0;
    markedk := 0;
    FOR i:= 1 TO maxpair - 1 DO
	BEGIN
	IF markflag[i] THEN
	(* OLD:	IF prspace[i].markflag THEN  *)
	    BEGIN
	    markedk := markedk + 1;
	    markflag[i] := false
	    (* OLD: prspace[i].markflag := false *)
	    END
	ELSE
	    BEGIN
	    prspace[i].prcar := nilref;
	    mkitem(pairtag, freepair, prspace[i].prcdr);
	    freepair := i;
	    freedk := freedk + 1
	    END
	END;
    writeln(freedk,' PAIRS FREED.');
    writeln(markedk,' PAIRS IN USE.');
    writeln('MAX GC STACK WAS ',mxgcstk);
    END;
    (* xgcollect *)

    (********************************************************)
    (*                                                      *)
    (*                  lisp primitives                     *)
    (*                                                      *)
    (********************************************************)

    (* return r[1].r[2] in r[1] *)
PROCEDURE xcons;
    VAR p: integer;

    BEGIN
    (* push args onto stack, in case we need to garbage collect the *)
    (* references will be detected.                                 *)
    alloc(2);
    stk[st] := r[1];
    stk[st-1] := r[2];

    IF prspace[freepair].prcdr = nilref THEN xgcollect;

    p := freepair;
    freepair := info_of(prspace[p].prcdr);
    prspace[p].prcar := stk[st];
    prspace[p].prcdr := stk[st - 1];
    mkpair(p, 1);       (* leave r[1] pointing at new pair. *)

    consknt := consknt + 1;
    dealloc(2);
    END;

PROCEDURE xncons;
    BEGIN r[2] := nilref;
    xcons;
    END;

PROCEDURE xxcons;
    BEGIN rxx := r[1];
    r[1] := r[2];
    r[2] := rxx;
    xcons;
    END;

    (* return car of r[1] in r[1] *)
PROCEDURE xcar;
    BEGIN
    IF tag_of(r[1]) = pairtag THEN
	r[1] := prspace[info_of(r[1])].prcar
    ELSE
	mkitem(errtag, notpair, r[1]);
    END;

PROCEDURE xcdr;
    BEGIN
    IF tag_of(r[1]) = pairtag THEN
	r[1] := prspace[info_of(r[1])].prcdr
    ELSE
	mkitem(errtag, notpair, r[1]);
    END;

PROCEDURE xrplaca;
    BEGIN
    IF tag_of(r[1]) = pairtag THEN
	prspace[info_of(r[1])].prcar:=r[2]
    ELSE
	mkitem(errtag, notpair, r[1]);
    END;

PROCEDURE xrplacd;
    BEGIN
    IF tag_of(r[1]) = pairtag THEN
	prspace[info_of(r[1])].prcdr :=r[2]
    ELSE
	mkitem(errtag, notpair, r[1]);
    END;

    (* anyreg car and cdr *)
PROCEDURE anycar(VAR a, b: itemref);
    BEGIN
    IF tag_of(a) = pairtag THEN
	b := prspace[info_of(a)].prcar
    ELSE
	mkitem(errtag, notpair, b);
    END;

PROCEDURE anycdr(VAR a, b: itemref);
    BEGIN
    IF tag_of(a) = pairtag THEN
	b := prspace[info_of(a)].prcdr
    ELSE
	mkitem(errtag, notpair, b);
    END;


    (********************************************************)
    (*                                                      *)
    (*              compress & explode                      *)
    (*                                                      *)
    (********************************************************)
PROCEDURE compress;     (* returns new id from list of chars *)
      VAR i: stringp;
          clist, c: itemref;
          found: boolean;
          int: integer;

    FUNCTION is_int(i: stringp; VAR int: longint): boolean;
        VAR negative, could_be: boolean;

        BEGIN   (* is_int *)
        int := 0;
        could_be := true;
        negative := strspace[i] = '-';
        IF negative OR (strspace[i] = '+') THEN i := i + 1;

        WHILE could_be AND (strspace[i] <> eos) DO
            BEGIN
            IF (strspace[i] >= '0') AND (strspace[i] <= '9') THEN
                 int := int * 10 + (ord(strspace[i]) - ord('0'))
            ELSE could_be := false;
            i := i + 1
            END;

        IF negative THEN int := -int;
        is_int := could_be
        END     (* is_int *);

    BEGIN     (* compress *)
    clist := r[1];        (* list of chars *)
    i := freestr; (* point to possible new string *)

    WHILE (i < maxstrsp) AND (clist <> nilref) DO
        BEGIN
        IF tag_of(clist) = PAIRTAG THEN
            BEGIN
            c := prspace[info_of(clist)].prcar;
            clist := prspace[info_of(clist)].prcdr;
            IF tag_of(c) = IDTAG THEN
                IF (info_of(c) > choffset) AND
                   (info_of(c) < choffset + 128) THEN 
                    BEGIN 
                    strspace[i] := chr(info_of(c) - choffset);
                    i := i + 1
                    END
                ELSE 
               writeln('*****COMPRESS: LIST ID NOT SINGLE CHAR')
            ELSE 
           writeln('*****COMPRESS: LIST ITEM NOT ID');
            END 
        ELSE 
       writeln('*****COMPRESS: ITEM NOT LIST')
        END (* WHILE *);

    strspace[i] := eos;   (* terminate string *)

    IF (i >= maxstrsp) THEN
	writeln('*****STRING SPACE EXHAUSTED')
    ELSE IF is_int(freestr, int) THEN
         mkint(int, 1)
    ELSE (* look the name up, return itemref for it *)
        BEGIN
        putnm(freestr, r[1], found);
	IF NOT found THEN
	    freestr := i + 1;
	END
    END       (* compress *);

PROCEDURE explode;      (* returns list of chars from id or int *)
      
      FUNCTION id_explode(i: stringp): itemref;
          BEGIN (* id_explode *)
          IF strspace[i] = eos THEN id_explode := nilref
          ELSE 
              BEGIN
              r[2] := id_explode(i + 1);
              mkident(ord(strspace[i]) + choffset, 1);
              xcons;
              id_explode := r[1]
              END
          END   (* id_explode *);

     FUNCTION int_explode(i: integer): itemref;
          VAR negative: boolean;

          BEGIN (* int_explode *)
          r[1] := nilref;
          IF i < 0 THEN
              BEGIN negative := true;
              i := -i
              END
          ELSE negative := false;

          WHILE i > 0 DO
              BEGIN
              r[2] := r[1];
              mkident(i MOD 10 + ord('0') + choffset, 1);
              xcons;
              i := i DIV 10
              END;

          IF negative THEN
              BEGIN 
              r[2] := r[1];
              mkident(ord('-') + choffset, 1);
              xcons
              END;
          int_explode := r[1]
          END (* int_explode *);

      BEGIN     (* explode *)
      IF tag_of(r[1]) = IDTAG THEN 
          r[1] := id_explode(idspace[info_of(r[1])].idname)
      ELSE IF tag_of(r[1]) = INTTAG THEN 
          r[1] := int_explode(info_of(r[1]))
      ELSE IF tag_of(r[1]) = FIXTAG THEN
          r[1] := int_explode(intspace[info_of(r[1])])
      ELSE 
     writeln('***** EXPLODE: ARG BAD TYPE')
      END       (* explode *);


    (********************************************************)
    (*                                                      *)
    (*                    i/o primitives                    *)
    (*                                                      *)
    (********************************************************)

procedure xopen;

var s1: string; i,j : integer;

  handler ResetError(name: PathName);
  begin
    writeln('**** Could not open file -  ',name,' for read');
    exit(xopen);
  end;

  handler RewriteError(name: PathName);
  begin
    writeln('**** Could not open file -  ',name,' for write');
    exit(xopen);
  end;
  
begin
      IF tag_of(r[1]) = IDTAG THEN 
      begin
        i := idspace[info_of(r[1])].idname;
        s1[0] := chr(255);
        j:= 0;
        WHILE (i <= maxstrsp) AND (strspace[i] <> eos) do
        begin
          j:= j + 1;
          s1[j] := strspace[i];
          i:= i + 1;
        end;
        s1[0]:= chr(j);
        
        IF tag_of(r[2]) = IDTAG THEN 
         case  strspace[idspace[info_of(r[2])].idname] of
         'i', 'I': begin reset(finput,s1); mkint(3,1) end;
         'o', 'O': begin rewrite(foutput,s1); mkint(4,1) end;
         otherwise: writeln('**** OPEN: ARG2 NOT INPUT/OUTPUT');
         end  else writeln('**** OPEN: ARG2 BAD TYPE')
     end else writeln('**** OPEN: ARG1 BAD TYPE');
end;

procedure xclose;

begin
  case info_of(r[1]) of
  1,2: ;
  3: close(finput);
  4: close(foutput);
  end;
end;

PROCEDURE xrds;
  (* Select channel for input *)
  VAR tmp:longint;
    BEGIN
        tmp:=inchnl;
        inchnl := info_of(r[1]);
         mkint(tmp,1)
    END;

PROCEDURE xwrs;
  (* Select channel for output *)
  VAR tmp:longint;
    BEGIN
        tmp:=outchnl;
        outchnl := info_of(r[1]);
        mkint(tmp,1)
    END;

PROCEDURE xterpri;
(* need to change for multiple output channels.  *)
    BEGIN
     case outchnl of
     1: writeln(' ');

     2: writeln(foutput,' ')
     end;
   END;


PROCEDURE xwrtok;
    (* doesn't expand escaped characters in identifier names *)
    VAR
      temp_real: real; (* KLUDGE: for bug *)
	i: integer;
    BEGIN
      case outchnl of
      1: BEGIN
    IF tag_of(r[1]) = inttag THEN
	BEGIN
	IF info_of(r[1]) = 0 THEN
	    write('0')
	ELSE
	    write('  ', info_of(r[1]):0);
	END

    ELSE IF tag_of(r[1]) = fixtag THEN
	     write(intspace[info_of(r[1])])

	 ELSE IF tag_of(r[1]) = flotag THEN
                BEGIN temp_real:= flospace[info_of(r[1])];
                  write( '* Real number bug *', trunc (temp_real))
                END
	      ELSE IF tag_of(r[1]) = idtag THEN
		       BEGIN
		       i := idspace[info_of(r[1])].idname;
		       WHILE (i <= maxstrsp) AND (strspace[i] <> eos) DO
			   BEGIN
			   write(strspace[i]);
			   i:= i + 1;
			   END;
		       END

		   ELSE IF tag_of(r[1]) = chartag THEN
		    write(chr(info_of(r[1]) - choffset))

		   ELSE IF tag_of(r[1]) = errtag THEN
		         writeln(' *** Error # ', '  ',info_of(r[1]):0)
		   ELSE IF tag_of(r[1]) = codetag THEN
			   write(' ## ','  ', info_of(r[1]):0)

		   ELSE  write(' ? ','  ' ,tag_of(r[1]):0,' /  ' ,info_of(r[1]):0,' ? ');
    END;
    
    4: BEGIN
    IF tag_of(r[1]) = inttag THEN
	BEGIN
	IF info_of(r[1]) = 0 THEN
	    write(foutput,'0')
	ELSE
	    write(foutput,'  ', info_of(r[1]):0);
	END

    ELSE IF tag_of(r[1]) = fixtag THEN
	     write(foutput,intspace[info_of(r[1])])

	 ELSE IF tag_of(r[1]) = flotag THEN
                BEGIN temp_real:= flospace[info_of(r[1])];
                  write(foutput, '* Real number bug *', trunc (temp_real))
                END
	      ELSE IF tag_of(r[1]) = idtag THEN
		       BEGIN
		       i := idspace[info_of(r[1])].idname;
		       WHILE (i <= maxstrsp) AND (strspace[i] <> eos) DO
			   BEGIN
			   write(foutput,strspace[i]);
			   i:= i + 1;
			   END;
		       END

		   ELSE IF tag_of(r[1]) = chartag THEN
		    write(foutput,chr(info_of(r[1]) - choffset))

		   ELSE IF tag_of(r[1]) = errtag THEN
		         writeln(foutput,' *** Error # ', '  ',info_of(r[1]):0)
		   ELSE IF tag_of(r[1]) = codetag THEN
			   write(foutput,' ## ','  ', info_of(r[1]):0)

		   ELSE  write(foutput,' ? ','  ' ,tag_of(r[1]):0,' /  ' ,info_of(r[1]):0,' ? ');
    END;
    END; (*case*)
  end; (*wrtoken*)
  
  
PROCEDURE rdchnl(chnlnum: integer; VAR ch: onechar);
    BEGIN
    IF (chnlnum < 1) OR (chnlnum > inchns) THEN
	writeln('*****BAD INPUT CHANNEL FOR RDCHNL',chnlnum)
    ELSE
	CASE chnlnum OF
	    1:  BEGIN
	    ch := symin^;  (* a little strange, but avoids  *)
	    get(symin);              (* initialization problems *)
	    ichrbuf[inchnl] := symin^; (* Peek ahead *)
	    END;

	    2:  BEGIN
	    ch := input^;
	    get(input);
	    ichrbuf[inchnl] := input^;
	    END;

	    3:  BEGIN
	    ch := finput^;
	    get(finput);
	    ichrbuf[inchnl] := finput^;
	    END;

    END;
    (* case *)
    END;
    (* rdchnl *)

FUNCTION eofchnl: boolean;
    BEGIN
	CASE inchnl OF
	    1:  eofchnl := eof(symin);
	    2:  eofchnl := eof(input);
	    3:  eofchnl := eof(finput);
	    END;
    END;


 FUNCTION eol: boolean;
    BEGIN
	CASE inchnl OF
	    1:  eol := eoln(symin);
	    2:  eol := eoln(input);
	    3:  eol := eoln(finput);
	    END;
    END;

    (********************************************************)
    (*                                                      *)
    (*                   token scanner                      *)
    (*                                                      *)
    (********************************************************)

PROCEDURE xrdtok;
LABEL 1;

    VAR
	ch,ch1,ChangedCh: onechar;
	i: integer;
	anint: longint;
	moreid: boolean;
	found: boolean;

    FUNCTION digit(ch: onechar): boolean;
	BEGIN
	digit := ( '0' <= ch ) AND ( ch <= '9');
	END;


    FUNCTION escalpha(VAR ch: onechar): boolean;
	(* test for alphabetic or escaped character.                 *)
	(* note side effect in ChangedCh.                                *)
	BEGIN
        ChangedCh := Ch;
	IF ( 'A' <= ch ) AND ( ch <= 'Z') THEN
	    escalpha := true
	ELSE IF ( ord('A')+32 <= ord(ch)) AND ( ord(ch) <= ord('Z')+32) THEN
               BEGIN
                 IF idspace[xraise].val=trueref
                  THEN Changedch := chr(ord(ch)-32);
		 escalpha := true;    (* lower case alphabetics *)
               END
	     ELSE IF ch='!' THEN
		      BEGIN
		      rdchnl(inchnl,ch);
                      ChangedCh:=Ch;
                      escalpha := true;
		      END
		  ELSE
		      escalpha := false;
	END;

    FUNCTION alphanum(VAR ch: onechar): boolean;
	(* test if escalfa or digit *)
	VAR b: boolean;
	BEGIN
        ChangedCh:=Ch;
	b := digit(ch);
	IF NOT b THEN b := escalpha(ch);
	alphanum := b;
	END;

    FUNCTION whitesp(ch: onechar): boolean;
    VAR ascode:integer
    BEGIN
        ascode:=ord(ch);
        WHITESP := (CH = SP) OR (ascode = CR) OR (ascode = LF)
	 OR (ascode = ht) or (ascode = nul);        (* null?? *)
    END; 

	(* reads fixnums...need to read flonums too *)

    var negflag : integer;
    BEGIN       (* xrdtok *)
1:
    IF NOT eofchnl THEN
        REPEAT                          (* skip leading white space. *)
            rdchnl(inchnl,ch)
        UNTIL (NOT whitesp(ch)) OR eofchnl;
    IF eofchnl THEN
        mkitem(chartag, eofcode + choffset, r[1])
        (* should really return !$eof!$  *)
    ELSE
        BEGIN
        IF digit(ch) or  (ch = '-') THEN
            set_tag(r[1], inttag)
        ELSE IF escalpha(ch) THEN
                 set_tag(r[1], idtag)
             ELSE
                 set_tag(r[1], chartag);

        CASE tag_of(r[1]) OF
            chartag:  BEGIN
                  if ch = begin_comment then
                      BEGIN
                      while not eol do rdchnl(inchnl, ch);
                      (*REPEAT rdchnl(inchnl, ch)*) 
                      (*UNTIL eol;        (of selected input *)
                      rdchnl(inchnl, ch);
                      GOTO 1
                      END;
                  set_tag(r[1], idtag);
                  mkitem(inttag, chartype, idspace[xtoktype].val);
                  set_info(r[1], ord(ch) + choffset);
                  END;
            inttag:   BEGIN
                 mkitem(inttag, inttype, idspace[xtoktype].val);
                 negflag := 1;
                 if ch = '-' then 
                     begin
                       anint := 0;
                       negflag := -1
                     end  else
                     anint := ord(ch) - ord('0');
                 WHILE digit(ichrbuf[inchnl]) DO
                     BEGIN
                     rdchnl(inchnl,ch);
                     anint := 10 * anint + (ord(ch) - ord('0'))
                     END;
                 anint := anint * negflag;
                 set_info(r[1], anint)
                 END;
            idtag:    BEGIN
                mkitem(inttag, idtype, idspace[xtoktype].val);
                i := freestr; (* point to possible new string *)
                moreid := true;
                WHILE (i < maxstrsp) AND moreid DO
                    BEGIN
                    strspace[i] := ChangedCh; (* May have Case Change, etc *)
                    i:= i + 1;
                    moreid :=alphanum(ichrbuf[inchnl]);  (* PEEK ahead char *)
                    IF moreid THEN rdchnl(inchnl,ch) (* Advance readch *)
                    END;
                strspace[i] := eos;   (* terminate string *)
                IF (i >= maxstrsp) THEN
                    writeln('*****STRING SPACE EXHAUSTED')
                ELSE  (* look the name up, return itemref for it *)
                    BEGIN
                    putnm(freestr, r[1], found);
                    IF NOT found THEN
                        freestr := i + 1;
                    END;
                END;
                (* of case idtag *)
            END;
        (* of case *)
        END;
    END;
    (* xrdtok *)
    (* for DEBUG *)
    (********************************************************)
    (*                                                      *)
    (*                    initialization                    *)
    (*                                                      *)
    (********************************************************)


PROCEDURE init;
    (* initialization procedure depends on  *)
    (* ability to load stack with constants *)
    (* from a file.                         *)
    VAR
	strptr: stringp;
	nam: PACKED ARRAY[1..3] OF onechar;
	(* holds 'nil', other strings? *)
	i, n: integer;
	idref: itemref;
	found: boolean;

	(* init is divided into two parts so it can compile on terak *)
    PROCEDURE init1;
	BEGIN

	(* initialize top of stack *)
	st := 0;

	freefloat := 1;
	freeint := 1;

	(* define nilref - the id, nil, is defined a little later. *)
	freeident := 1;
	mkitem(idtag, freeident, nilref);

	(* initialize pair space. *)
	FOR i := 1 TO maxpair - 1 DO      (* initialize free list. *)
	    BEGIN
          (* OLD: prspace[i].MarkFlag := false; *)
	    prspace[i].prcar := nilref;         (* just for fun *)
	    mkitem(pairtag, i + 1, prspace[i].prcdr);
	    END;
	prspace[maxpair].prcar := nilref;
	prspace[maxpair].prcdr := nilref;       (* end flag *)
	freepair := 1;                  (* point to first free pair *)


	(* initialize identifier space and string space. *)
	freestr := 1;
	FOR i := 0 TO hidmax - 1 DO
	    idhead[i] := nillnk;
	FOR i := 1 TO maxident DO
	    BEGIN
	    IF i < maxident THEN
		idspace[i].idhlink := i + 1
	    ELSE    (* nil to mark the final identifier in the table. *)
		idspace[i].idhlink := nillnk;
	    (* set function cells to undefined *)
	    mkitem(errtag, undefined, idspace[i].funcell);
	    mkitem(errtag, undefined, idspace[i].val);
	    mkitem(errtag, undefined, idspace[i].plist);
	    
	    END;

	(* nil must be the first identifier in the table--id #1 *)
	(* must fill in fields by hand for nilref.*)
	(* putnm can handle any later additions.  *)
	nam := 'NIL';
	strptr := freestr;
	FOR i := 1 TO 3 DO
	    BEGIN
	    strspace[strptr] := nam[i];
	    strptr:= strptr + 1;
	    END;
	strspace[strptr] := eos;
        putnm(freestr, nilref, found);
	IF NOT found THEN
	    freestr := strptr + 1;

	(* make the single character ascii identifiers, except nul(=eos). *)
	FOR i := 1 TO 127  DO
	    BEGIN
	    strspace[freestr] := chr(i);
	    strspace[freestr + 1] := eos;
	    putnm(freestr, idref, found);
	    IF NOT found THEN
		freestr := freestr + 2;
	    IF i = ord('T') THEN
		trueref := idref;
	    (* returns location for 't. *)
	    END;

	(* clear the counters *)
        idspace[xraise].val := trueref;
	gccount := 0;
	consknt := 0;
	END;
	(* init1 *)

    PROCEDURE init2;
	BEGIN
	(* load "symbol table" with identifiers, constants, and functions.  *)
	inchnl := 1;        (* select symbol input file. *)
	outchnl := 1;        (* select standard output file. *)
	reset(symin,'paslsp.ini');
	reset(input);
	rewrite(output);
	xrdtok;     (* get count of identifiers. *)
	IF tag_of(r[1]) <> inttag THEN
	    writeln('*****BAD SYMBOL TABLE, INTEGER EXPECTED AT START');
	n := info_of(r[1]);
	FOR i := 1 TO n DO
	    xrdtok;
	(* reading token magically loads it into id space. *)
	xrdtok;         (* look for zero terminator. *)
	IF (tag_of(r[1]) <> inttag) OR (info_of(r[1]) <> 0) THEN
	    writeln('*****BAD SYMBOL TABLE, ZERO EXPECTED AFTER IDENTIFIERS');

	xrdtok;         (* count of constants  *)
	IF tag_of(r[1]) <> inttag THEN
    writeln('*****BAD SYMBOL TABLE, INTEGER EXPECTED BEFORE CONSTANTS');
	n := info_of(r[1]);
	alloc(n);       (* space for constants on the stack *)
	FOR i := 1 TO n DO
	    BEGIN
	    xread;
	    stk[i] := r[1];
	    END;
	xrdtok;
	IF (tag_of(r[1]) <> inttag) OR (info_of(r[1]) <> 0) THEN
    writeln('*****BAD SYMBOL TABLE, ZERO EXPECTED AFTER CONSTANTS');

	xrdtok;     (* count of functions. *)
	IF tag_of(r[1]) <> inttag THEN
	   writeln('*****BAD SYMBOL TABLE, INTEGER EXPECTED BEFORE FUNCTIONS');
	n := info_of(r[1]);
	FOR i := 1 TO n DO
	    (* for each function *)
	    (* store associated code *)
	    BEGIN
	    xrdtok;
	    mkitem(codetag, i, idspace[info_of(r[1])].funcell);
	    END;
	xrdtok;
	IF (tag_of(r[1]) <> inttag) OR (info_of(r[1]) <> 0) THEN
    writeln('*****BAD SYMBOL TABLE, ZERO EXPECTED AFTER FUNCTIONS');

	END;
	(* init2 *)
    BEGIN       (* init *)
    init1;
    init2;
    END;
    (* init *)

    (********************************************************)
    (*                                                      *)
    (*                 arithmetic functions                 *)
    (*                                                      *)
    (********************************************************)

PROCEDURE xadd1;
    VAR i: longint;

    BEGIN
    int_val(r[1], i);
    mkint(i + 1, 1)
    END;

PROCEDURE xdifference;
    VAR i1, i2: longint;

    BEGIN
    int_val(r[1], i1);
    int_val(r[2], i2);
    mkint(i1 - i2, 1)
    END;

PROCEDURE xdivide;      (* returns dotted pair (quotient . remainder). *)
    VAR quot, rem: integer;
	i1, i2: longint;

    BEGIN
    int_val(r[1], i1);
    int_val(r[2], i2);

    mkint(i1 DIV i2, 1);
    mkint(i1 MOD i2, 2);
    xcons
    END;

PROCEDURE xgreaterp;
    VAR i1, i2: longint;

    BEGIN
    int_val(r[1], i1);
    int_val(r[2], i2);

    IF i1 > i2 THEN
	r[1] := trueref
    ELSE
	r[1] := nilref;
    END;

PROCEDURE xlessp;
    VAR i1, i2: longint;

    BEGIN
    int_val(r[1], i1);
    int_val(r[2], i2);

    IF i1 < i2 THEN
	r[1] := trueref
    ELSE
	r[1] := nilref;
    END;

PROCEDURE xminus;
    VAR i: longint;

    BEGIN
    int_val(r[1], i);
    mkint(-i, 1)
    END;

PROCEDURE xplus2;
    VAR i1, i2: longint;

    BEGIN
    int_val(r[1], i1);
    int_val(r[2], i2);
    mkint(i1 + i2, 1)
    END;

PROCEDURE xquotient;
    VAR i1, i2: longint;

    BEGIN
    int_val(r[1], i1);
    int_val(r[2], i2);
    mkint(i1 DIV i2, 1)
    END;

PROCEDURE xremainder;
    VAR i1, i2: longint;

    BEGIN
    int_val(r[1], i1);
    int_val(r[2], i2);
    mkint(i1 MOD i2, 1)
    END;

PROCEDURE xtimes2;
    VAR i1, i2: longint;

    BEGIN
    int_val(r[1], i1);
    int_val(r[2], i2);
    mkint(i1 * i2, 1)
    END;
    (* xtimes2 *)


    (********************************************************)
    (*                                                      *)
    (*                    support for eval                  *)
    (*                                                      *)
    (********************************************************)


PROCEDURE execute(code: integer);
    FORWARD;

    (* Xapply(fn,arglist)-- "fn" is an operation code. *)
PROCEDURE xxapply;
    VAR
	i: integer;
	code: integer;
	tmp: itemref;
	tmpreg: ARRAY[1..maxreg] OF itemref;
    BEGIN
    code := info_of(r[1]);
    r[1] := r[2];
    i := 1;
    (* spread the arguments  *)
    WHILE (r[1] <> nilref) AND (i <= maxreg) DO
	BEGIN
	tmp := r[1];
	xcar;
	tmpreg[i] := r[1];
	i := i + 1;
	r[1] := tmp;
	xcdr;
	END;
    WHILE i > 1 DO
	BEGIN
	i := i - 1;
	r[i] := tmpreg[i];
	END;
    execute(code);
    END;

#padtwv (* PreProcessor Version - Run  through Filter *)
#p      (* PERQ version *)
#a      (* Apollo Version *)
#d      (* DEC-20 Version *)
#t      (* Terak Version *)
#w      (* Wicat Version *)
#v      (* VAX version *)
(*********************************************************************
                                    
                PASCAL BASED MINI-LISP

 File:  PAS0.PAS - PASCAL/LISP KERNEL
 ChangeHistory:
    3 Mar 82  RO: Apollo version finished, some changes for WICAT
   16 Feb 82  RO: Implement !*ECHO
   11 Feb 82  RO: Allow string as alias for identifier
    8 Feb 82  RO: Fix GC bug & clean up for apollo
   19 Jan 82  RO: Change I/O channel assginments
   29 Dec 81  RO: File I/O for apollo & wicat
   23 Dec 81  RO: More changes for Apollo & Wicat
    9 Dec 81, RO: Remove apollo specific I/O.
    1 Dec 81  RO: I/O fixes for wicat & fixnum bug
   14 Nov 81, MLG:add some PERQ updates from Voelker
   28 Oct 81, RO: GENSYM & fixnum gc
 
   All RIGHTS RESERVED
   COPYRIGHT (C) - 1981 - M. L. Griss and R. Ottenheimer
   Computer Science Department
           University of Utah

           Do Not distribute with out written consent of M. L. Griss

********************************************************************)

#t (*$S+*) (* swapping mode *)
#t (*$G+*) (* goto is legal *)

#adtvw PROGRAM pas0 ; (* (input*,output) *)
#p    PROGRAM pas0 (input,output, symin, finput,foutput);
    (************************************************************)
    (* support routines for a "lisp" machine.  uses a register  *)
    (* model with a stack for holding frames.  stack also used  *)
    (* to hold compiler generated constants.                    *)
    (* written by:                                              *)
    (*      william f. galway, martin l. griss                  *)
    (*      ralph ottenheimer                                   *)
    (* append pas1...pasn at  end                               *)
    (* -------------------------------------------------------- *)

    (* I/O channel assignments:
     1: symin, used to init symbol table
     2: stdin,
     3: stdout,
     4: finput,
     5: foutput.
    *)

    (************************************************************)
#a (* Apollo System include files *)
#a %include '/sys/ins/base.ins.pas';
#a %include '/sys/ins/pgm.ins.pas';


#p imports Stream from Stream;
#p imports system from system;
#p imports io_others from io_others;
#p imports io_unit from io_unit;

    (************************************************************)

CONST
#aptv    (* for terak, perq, Apollo, vax  *)
#aptvw sp = ' '; 
#aptvw ht = 9;          (* ascii codes *)
#aptvw lf = 10;
#aptvw cr = 13; 
#aptvw nul = 0;

#d    eos = nul;      (* terminator character for strings. *)
#t    (* use eos=chr(nul)  *)
#av  eos=chr(nul) ;
#pw  eos = chr(0);        (* KLUDGE: null string *)
#adtwpv   inchns = 5;       (* number of input channels.  *)
#adtwpv   outchns = 5;      (* number of output channels. *)
    begin_comment = '%';

(* Initial symbols, needed in Kernel *)
    xtoktype  = 129;  (* slot in idspace for toktype. *)
    xbstack   = 130;  (* Bstack Pointer *)
    xthrowing = 131;  (* If throw mode *)
    xinitform = 132;  (* for restart *)
    xraise    = 133;  (* for RAISE of lc in ids *)
    Xinput    = 134;  (* For Open *)
    Xoutput   = 135;  (* For Open *)
    xQuote    = 138;  (* For quoting ids in pascal code. *)
    xEcho     = 136;  (* raw input is echoed if not NIL. *)
    chartype  =  3;   (* various token types *)
    inttype  =  1;
    idtype  =  2;

    max_gsym = 4;       (* number of digits in gen'd id. *)

#dt  shift_const = 8192; (* tags and info are packed into an integer *)
#a   (* no shift const *)
#p   (* no shift const *)
#w   (* no shift const *)
#dt  (* assumed to be at least 16 bits long.  low order 13 bits  *)
#dt  (* are the info, top 3 are the tag.                         *)
#dt    int_offset = 4096;  (* small integers are stored 0..8191    *)
#dt (* instead of -4096..4095 because it will pack smaller      *)
#dt (* under ucsd pascal.                                       *)
#apw     int_offset = 32767; (* Apollo, PERQ and WICAT items are records *)

    (* the various tags - can't use a defined scalar type *)
    (* because of the lack of convertion functions.       *)
    inttag = 0;    (* info is an integer                  *)
    chartag = 1;   (* info is a character code            *)
    pairtag = 2;   (* info points to pair                 *)
    idtag = 3;     (* info points to identifier           *)
    codetag = 4;   (* info is index into a case statement *)
    (*                that calls appropriate function.    *)
    errtag = 5;    (* info is an error code - see below.  *)
    fixtag = 6;    (* info points to a full word (or      *)
    (*                longer) integer.                    *)
    strtag = 7;    (* info points to a string.            *)

    (* error codes.  corresponding to tag = errtag.  *)
    noprspace = 1;    (* no more "pair space"--can't cons. *)
    notpair = 2;      (* a pair operation attempted on a non-pair. *)
    noidspace = 3;    (* no more free identifiers *)
    undefined = 4;    (* used to mark undefined function cells (etc?) *)
    noint = 5;        (* no free integer space after garbage collection *)
    notid = 6;

     (* data space sizes *)
(* remember pointers to these things are inums, sometimes quite small *)
#av      maxpair = 10000;  (* max number of pairs allowed. *)
#dpw     maxpair = 3700;   (* max number of pairs allowed. *)
#t       maxpair = 1000;   (* max number of pairs allowed *)
#tw      maxident = 400;   (* max number of identifiers *)
#adpv    maxident = 800;   (* max number of identifiers *)
#adpv    maxstrsp = 4000;  (* size of string (literal) storage space. *)
                           (* beware - string pointers are inums. *)
#tw      maxstrsp = 2000;  (* size of string (literal) storage space. *)
#adpv    maxintsp = 200;   (* max number of long integers allowed *) 
#tw      maxintsp = 2;   (* max number of long integers allowed *)

    hidmax = 50;      (* number of hash values for identifiers *)
    maxgcstk = 100;   (* size of garbage collection stack.    *)
    stksize = 500;    (* stack size *)
    maxreg = 15;      (* number of registers in lisp machine. *)

    eofcode = 26;     (* magic character code for eof, ascii for *)
    (*  cntrl-z.  kludge, see note in xrdtok.  *)
    choffset = 1;     (* add choffset to ascii code to get address  *)
    (* in id space for corresponding identifier.  *)
    nillnk = 0;       (* when integers are used as pointers.  *)
#dptw end_flag = maxint;  (* marks end of fixnum space *)
#a    end_flag = -2147483648;  (* marks end of fixnum space *)

    (************************************************************)

TYPE
#w   regblk_type = array[0..16] of longint;
#d   onechar = ascii;     (* for DEC *)
#aptvw    onechar = char;     (* for terak,perq,Apollo,Wicat*)
#awv FileName=Packed ARRAY[0..59] of onechar;
#p   FileName: string;
#t   FileName: string[60];
#d   FileName=Packed ARRAY[1..9] of onechar;

    (* note we allow zero for id_ptr, allowing a "nil" link. *)
    stringp = 1..maxstrsp;        (* pointer into string space. *)
    id_ptr = 0..maxident;            (* pointer into id space. *)

#dtv    itemref = integer;
#apw      itemref = RECORD
#apw                tag:integer;
#apw                info:integer;
#apw                END;
    itemtype = 0..7;    (* the tags *)


    pair = PACKED RECORD
                      prcar: itemref;
                      prcdr: itemref;
                  END;


#aw       ascfile = text;
#dptv    ascfile = PACKED FILE OF onechar;
#d       textfile =PACKED FILE of char;

    ident = PACKED RECORD           (* identifier *)
                       idname: stringp;
                       val: itemref;       (* value *)
                       plist: itemref;     (* property list *)
                       funcell: itemref;   (* function cell *)
                       idhlink: id_ptr;    (* hash link *)
                   END;
#dptvw   longint = integer;
#a       longint = integer32;

    (************************************************************)

VAR
    (* global information *)
    nilref, trueref, tmpref: itemref; 
    (* refers to identifiers "nil", "t", and a temp to get around bug in. *)
    (* apollo & wicat pascal *)
    initphase: integer;                (* Start up *)
#adpvw r: ARRAY[1..maxreg] OF itemref;
#t     r: ARRAY[0..maxreg] OF itemref;  (* cuts code size down *)
    rxx,ryy: itemref;

#t  CHARCNT: INTEGER;   (* input buffer & pointer *)
#t  LINE: STRING;

    (* "st" is the stack pointer into "stk".  it counts the number of  *)
    (* items on the stack, so it runs from zero while the stack starts *)
    (* at one.                                                         *)
    st: 0..stksize;
    stk: ARRAY[1..stksize] OF itemref;

    (* pair space *)
    prspace: PACKED ARRAY[1..maxpair] OF pair; (* all pairs stored here. *)
    freepair: integer;          (* pointer to next free pair in prspace. *)

    (* identifier space *)
    idhead: ARRAY[0..hidmax] OF id_ptr;
    idspace: PACKED ARRAY[1..maxident] OF ident;
    freeident: integer;
    g_sym: ARRAY[1..max_gsym] OF onechar;

    (* string space *)
    strspace: PACKED ARRAY[1..maxstrsp] OF onechar;
    freestr: stringp;

    (* large integer space *)
    intspace: ARRAY[1..maxintsp] OF longint;
    freeint: 1..maxintsp;


    (* i/o channels *)
#p  (* files declared on header *)
#adptvw    symin: ascfile;
#adptvw    finput : ascfile;
#aptvw    foutput: ascfile;
#d       foutput: textfile;
#d  input: ascfile;
#a  IoStatus:Integer32;
    inchnl: 1..inchns;      (* current input channel number  *)
    outchnl: 1..outchns;    (* current output channel number *)

    (* "current character" for each input channel.                    *)
    (* may want to include more than one character at some later date *)
    (* (for more lookahead).                                          *)
    ichrbuf: ARRAY[1..inchns] OF onechar;

    (* for collecting statistics. *)
    gccount: integer;           (* counts garbage collections *)
    (* counts from last garbage collection. *)
    consknt: integer;           (* number of times "cons" called *)



(* ........ Everything nested inside CATCH *)

#w procedure _setjmp(var regblk:regblk_type);external;
#w procedure _long_jump(var regblk:regblk_type);external;

Procedure Xcatch;  (* ----------- Outermost Procedure ----------- *)
#adv LABEL 9999;
#w  (* need to use special ASM68 procedures for Wicat *)
 var catch_stk:0..stksize;
     catch_Bstk:itemref;
#w   Catch_regs:regblk_type;

PROCEDURE xread;
    FORWARD;

PROCEDURE xprint;
    FORWARD;

PROCEDURE xunbindto;
    FORWARD;

PROCEDURE xeval;
    FORWARD;

 Procedure Xthrow;
    begin (* throw value *)
        idspace[Xthrowing].val := trueref;
#dav     goto 9999
#w       _long_jump(Catch_regs);
#tp      exit(xeval)
    end (* throw *);
#p (* Special handlers *)
#p Handler CtlC;  (* ------- handle runaway aborts ------- *)

#p begin
#p    write('^C');
#p    IOKeyClear;
#p    IObeep;
#p    if initphase > 1 then Xthrow;
#p end;

    (********************************************************)
    (*                                                      *)
    (*             item selectors & constructors            *)
    (*                                                      *)
    (********************************************************)

#a (* use some SHIFTS ? *)

FUNCTION tag_of(item: itemref): itemtype;
#t       VAR gettag: PACKED RECORD
#t                   CASE boolean OF
#t                   TRUE: (i: itemref);
#t                   FALSE: (info: 0..8191;
#t                           tag: 0..7)
#t               END;

    BEGIN (* tag_of *)
#t    gettag.i := item;
#t    tag_of := gettag.tag
#dv   tag_of := item DIV shift_const;
#apw  tag_of := item.tag;
    END;
    (* tag_of *)

FUNCTION info_of(item: itemref): integer;
#t       VAR getinfo: PACKED RECORD
#t                   CASE boolean OF
#t                   TRUE: (i: itemref);
#t                   FALSE: (info: 0..8191;
#t                           tag: 0..7)
#t               END;

 BEGIN (* info_of *)
#t    getinfo.i := item;
#t    if getinfo.tag = inttag then
#t        info_of := getinfo.info - int_offset
#t    else info_of := getinfo.info
#dv  IF item DIV shift_const = inttag THEN
#dv      info_of := item MOD shift_const - int_offset
#dv  ELSE
#dv      info_of := item MOD shift_const
#apw   info_of := item.info
    END;
    (* info_of *)

FUNCTION xnull(item: itemref): boolean;
    BEGIN
    xnull := (tag_of(item) = tag_of(nilref)) AND 
             (info_of(item) = info_of(nilref))
    END;


PROCEDURE mkitem(tag: itemtype; info: longint; VAR item: itemref);
    (* do range checking on info. ints run from -4096 to +4095 *)
    (* everything else runs from 0 to 8191. ints & chars       *)
    (* contain their info, all others points into an           *)
    (* appropriate space.                                      *)

    PROCEDURE mkfixint;
        VAR nextfree: integer;

        PROCEDURE gc_int;
            VAR i: integer;
            mark_flag: PACKED ARRAY[1..maxintsp] OF boolean;


            PROCEDURE mark(u: itemref);
                BEGIN (* Mark *)
                IF tag_of(u) = pairtag THEN
                    BEGIN
                    mark(prspace[info_of(u)].prcar);
                    mark(prspace[info_of(u)].prcdr)
                    END
                ELSE IF tag_of(u) = fixtag THEN
                    mark_flag[info_of(u)] := true
                END (* Mark *);

            BEGIN (* Gc_int *)
            writeln('*** Gc int');
            FOR i := 1 TO maxintsp do   (* clear mark flags *)
                mark_flag[i] := false;

            FOR i := 1 TO st DO             (* mark from the stack *)
                Mark(stk[i]);

            FOR i := 1 TO maxident DO       (* mark from the symbol table *)
                BEGIN
                Mark(idspace[i].val);
                Mark(idspace[i].plist);
                Mark(idspace[i].funcell)        (* probably NOT necessary *)
                END;

            (* reconstruct free list *)
            FOR i := 1 TO maxintsp - 1 DO
                IF NOT mark_flag[i] THEN
                    BEGIN
                    intspace[i] := freeint;
                    freeint := i
                    END
            END (* Gc_int *);

        BEGIN (* mkfixint *)
        IF info = end_flag THEN (* user can't use magic number *)
                BEGIN info := 0;
                writeln('*****Mkfixint: Info too large')
                END;
        IF intspace[freeint] = end_flag THEN 
            gc_int;    (* garbage collect intspace *)

        IF intspace[freeint] <> end_flag THEN 
            BEGIN    (* convert to fixnum *)
            tag := fixtag;
            nextfree := intspace[freeint];
            intspace[freeint] := info;
            info := freeint;        (* since we want the pointer *)
            freeint := nextfree
            END
        ELSE
            BEGIN mkitem(errtag, noint, r[1]);
            writeln('***** Integer space exhausted')
            END
        END;
        (* mkfixint *)


    BEGIN (* mkitem *)
    IF tag = inttag THEN
#apw     BEGIN
        IF (info < -int_offset) OR (info > int_offset - 1) THEN mkfixint
#dtv   ELSE info := info + int_offset    (* info was in range so add offset *)
#apw     END
    ELSE IF tag = fixtag THEN mkfixint

         ELSE IF info < 0 THEN
                  BEGIN
                  writeln('*****Mkitem: bad neg');
#d                break(output); 
#dtv              halt;
#p                exit(pas0);
#a                pgm_$exit;
                  END;
    (* nothing special to do for other types *)

#dtv     (* pack tag and info into 16-bit item.   *)
#dtv     item := tag * shift_const + info
#apw     item.tag := tag;
#apw     item.info := info
    END;
    (* mkitem *)

PROCEDURE mkerr(info: longint; VAR item: itemref);
 Begin
     mkitem(errtag,info,item);
 End;


PROCEDURE set_info(VAR item: itemref; newinfo: longint);
    BEGIN (* set_info *)
    mkitem(tag_of(item), newinfo, item)
    END;
    (* set_info *)

PROCEDURE set_tag(VAR item: itemref; newtag: itemtype);
    BEGIN (* set_tag *)
    mkitem(newtag, info_of(item), item)
    END;
    (* set_tag *)

PROCEDURE mkident(id: integer; reg: integer);
    (* make identifier "id" in register "reg" *)
    BEGIN       (* mkident *)
    mkitem(idtag, id, r[reg]);
    END;
    (* mkident *)

PROCEDURE mkint(int: longint; reg: integer);
    BEGIN       (* mkint *)
    mkitem(inttag, int, r[reg]);
    END;
    (* mkint *)

PROCEDURE mkpair(pr: integer; reg: integer);
    BEGIN (* mkpair *)
    mkitem(pairtag, pr, r[reg])
    END;
    (* mkpair *)

PROCEDURE int_val(item: itemref; VAR number: longint);
    (* returns integer value of item (int or fixnum). *)
    (* must return 'number' in var parameter instead  *)
    (* of function value since long integers are not  *)
    (* a legal function type in ucsd pascal.          *)
    BEGIN (* int_val *)
    IF tag_of(item) = inttag THEN
        number := info_of(item)
    ELSE IF tag_of(item) = fixtag THEN
             number := intspace[info_of(item)]
    ELSE writeln(tag_of(item), ' *****Illegal data type for numeric operation')
        (* halt or fatal error *)
    END;
    (* int_val *)


    (********************************************************)
    (*                                                      *)
    (*                  stack allocation                    *)
    (*                                                      *)
    (********************************************************)

PROCEDURE alloc(n: integer);
    BEGIN
    IF n + st <= stksize THEN
        st := n+st
    ELSE
        BEGIN
        writeln('*****LISP stack overflow');
        writeln('     tried to allocate ',n);
        writeln('     current stack top is ',st);
#d      break(output);
        END;
    END;

PROCEDURE dealloc(n: integer);
    BEGIN
    IF st - n >= 0 THEN
        st := st - n
    ELSE
        writeln('*****Lisp stack underflow');
    END;

    (* optimized allocs *)

PROCEDURE alloc1;
    BEGIN alloc(1) END;

PROCEDURE dealloc1;
    BEGIN dealloc(1) END;

PROCEDURE alloc2;
    BEGIN alloc(2) END;

PROCEDURE dealloc2;
    BEGIN dealloc(2) END;

PROCEDURE alloc3;
    BEGIN alloc(3) END;

PROCEDURE dealloc3;
    BEGIN dealloc(3) END;


    (********************************************************)
    (*                                                      *)
    (*              support for register model              *)
    (*                                                      *)
    (********************************************************)

PROCEDURE load(reg: integer; sloc: integer);
    BEGIN
    IF sloc < 0 THEN r[reg] := r[-sloc]
    ELSE  r[reg] := stk[st-sloc];
    (* will, fix for load (pos,pos) *)
    END;

PROCEDURE store(reg: integer; sloc: integer);
    BEGIN
    stk[st-sloc] := r[reg];
    END;

    (* optimized load/store. *)
PROCEDURE load10;
    BEGIN
    load(1,0);
    END;

PROCEDURE store10;
    BEGIN
    store(1,0);
    END;

PROCEDURE storenil(sloc: integer);
    BEGIN
    stk[st-sloc] := nilref;
    END;


    (********************************************************)
    (*                                                      *)
    (*              identifier lookup & entry               *)
    (*                                                      *)
    (********************************************************)

function nmhash(nm: stringp): integer;
    CONST
        hashc = 256;
    VAR
        i,tmp: integer;
    BEGIN
    tmp := 0;
    i := 1;     (* get hash code from first three chars of string. *)
    WHILE (i <= 3) AND (strspace[nm+i] <> eos) DO
        BEGIN
        tmp := ord(strspace[nm+i]) + hashc*tmp;
        i := i + 1;
        END;
    nmhash := abs(tmp) MOD hidmax;      (* abs because mod is screwy. *)
    END;

FUNCTION eqstr(s1,s2: stringp): boolean;
    BEGIN
    WHILE (strspace[s1] = strspace[s2]) AND (strspace[s1] <> eos) DO
        BEGIN
        s1 := s1 + 1;
        s2 := s2 + 1;
        END;
    eqstr := (strspace[s1] = strspace[s2]);
    END;

PROCEDURE nmlookup(nm: stringp; VAR found: boolean; VAR hash: integer;
                   VAR loc: itemref);
    (* lookup a name in "identifier space".                                 *)
    (* "hash" returns the hash value for the name.                          *)
    (* "loc" returns the location in the space for the (possibly new)       *)
    (* identifier.                                                          *)
    BEGIN
    hash := nmhash(nm);
    mkitem(idtag, idhead[hash], loc);
    (* default is identifier, but may be "error". *)
    (* start at appropriate hash chain. *)

    found := false;
    WHILE (info_of(loc) <> nillnk) AND (NOT found) DO
        BEGIN
        found := eqstr(nm, idspace[info_of(loc)].idname);
        IF NOT found THEN
            set_info(loc, idspace[info_of(loc)].idhlink);
        (* next id in chain *)
        END;
    IF NOT found THEN               (* find spot for new identifier *)
        BEGIN
        IF freeident=nillnk THEN    (* no more free identifiers. *)
            BEGIN
            mkerr(noidspace, loc);
            writeln('*****Identifer space exhausted')
            END
        ELSE
            BEGIN
            set_info(loc, freeident);
            freeident := idspace[freeident].idhlink;
            END;
        END;
    END;

PROCEDURE putnm(nm: stringp; VAR z: itemref; VAR found: boolean);
    (* put a new name into identifier space, or return old location *)
    (* if it's already there.                                       *)
    VAR
        tmp: ident;
        hash: integer;
    BEGIN
    nmlookup(nm, found, hash, z);
    IF (NOT found) AND (tag_of(z) = idtag) THEN
        BEGIN
        tmp.idname := nm;
        tmp.idhlink := idhead[hash];   (* put new ident at head of chain     *)
        tmp.val := nilref;             (* initialize value and property list *)
        tmp.plist := nilref;
        tmp.funcell := nilref;         (* also, the function cell *)
        idhead[hash] := info_of(z);
        idspace[info_of(z)] := tmp;
        END;
    END;


    (********************************************************)
    (*                                                      *)
    (*              the garbage collector                   *)
    (*                                                      *)
    (********************************************************)

PROCEDURE xfaststat;
    (* give quick summary of statistics gathered *)
    BEGIN
#dw       writeln('Next free pair:   ', freepair, ' out of ', maxpair);
#dw       writeln('Next free fixnum: ', freeint, ' out of ', maxintsp);
#dw       writeln('Next free string: ', freestr, ' out of ', maxstrsp);
          writeln('Next free id loc: ', freeident, ' out of ', maxident);
          writeln('Pair space reclaimed ', gccount, ' times');
          writeln('Conses since last reclaim:',consknt);
          writeln('Stack top is:',st);
#d       break(output)
    END;


PROCEDURE xgcollect;
    VAR
        i: integer;
        markedk: integer;   (* counts the number of pairs marked *)
        freedk: integer;    (* counts the number of pairs freed. *)
        gcstkp: 0..maxgcstk; (* note the garbage collection stack   *)
        mxgcstk: 0..maxgcstk;           (* is local to this procedure. *)
        gcstk: ARRAY[1..maxgcstk] OF integer;
        markflag: PACKED ARRAY[1..maxpair] OF boolean;
        
    PROCEDURE pushref(pr: itemref);
        (* push the address of an unmarked pair, if that's what it is. *)
        BEGIN
        IF tag_of(pr) = pairtag THEN
            IF NOT markflag[info_of(pr)] THEN  (* was .markflag *)
                BEGIN
                IF gcstkp < maxgcstk THEN
                    BEGIN
                    gcstkp := gcstkp + 1;
                    gcstk[gcstkp] := info_of(pr);
                    IF gcstkp > mxgcstk THEN
                        mxgcstk := gcstkp;
                    END
                ELSE
                    BEGIN
                    writeln('*****Garbage stack overflow');
#dtv                halt;
#p                  exit(pas0);
#a                pgm_$exit;
                    END;
                END;
        END;

    PROCEDURE mark;
        (* "recursively" mark pairs referred to from gcstk. gcstk is used to *)
        (* simulate recursion.                                               *)
        VAR
            prloc: integer;
        BEGIN
        WHILE gcstkp > 0 DO
            BEGIN
            prloc := gcstk[gcstkp];
            gcstkp := gcstkp - 1;
            markflag[prloc] := true;
            pushref(prspace[prloc].prcdr);
            pushref(prspace[prloc].prcar);  (* trace the car first. *)
            END;
        END;

    BEGIN       (* xgcollect *)
    writeln;
    writeln('***Garbage collector called');
#d  break(output);
    gccount := gccount + 1;          (* count garbage collections. *)
    xfaststat;   (* give summary of statistics collected *)
    consknt := 0;       (* clear out the cons counter *)
    gcstkp := 0;        (* initialize the garbage stack pointer. *)
    mxgcstk := 0;       (* keeps track of max stack depth. *)

    (* clear markflags *)
    FOR i := 1 TO maxpair DO markflag[i] := false;
    (* mark things from the "computation" stack. *)
    FOR i := 1 TO st DO
        BEGIN
        pushref(stk[i]);
        mark;
        END;
    (* mark things from identifier space. *)
    FOR i := 1 TO maxident DO
        BEGIN
        pushref(idspace[i].val);
        mark;
        pushref(idspace[i].plist);
        mark;
        pushref(idspace[i].funcell);
        mark;
        END;

    (* reconstruct free list by adding things to the head. *)
    freedk := 0;
    markedk := 0;
    FOR i:= 1 TO maxpair - 1 DO
        BEGIN
        IF markflag[i] THEN
            BEGIN
            markedk := markedk + 1;
            markflag[i] := false
            END
        ELSE
            BEGIN
            prspace[i].prcar := nilref;
            mkitem(pairtag, freepair, prspace[i].prcdr);
            freepair := i;
            freedk := freedk + 1
            END
        END;
    writeln(freedk,' pairs freed.');
    writeln(markedk,' pairs in use.');
    writeln('Max gc stack was ',mxgcstk);
#d  break(output);
    mkint(gccount, 1) (* return number of garbage collections *)
    END;
    (* xgcollect *)

    (********************************************************)
    (*                                                      *)
    (*                  lisp primitives                     *)
    (*                                                      *)
    (********************************************************)

    (* return r[1].r[2] in r[1] *)
PROCEDURE xcons;
    VAR p: integer;

    BEGIN
    (* push args onto stack, in case we need to garbage collect the *)
    (* references will be detected.                                 *)
    alloc(2);
    stk[st] := r[1];
    stk[st-1] := r[2];

    IF xNull(prspace[freepair].prcdr) THEN xgcollect;

    p := freepair;
    freepair := info_of(prspace[p].prcdr);
    prspace[p].prcar := stk[st];
    prspace[p].prcdr := stk[st - 1];
    mkpair(p, 1);       (* leave r[1] pointing at new pair. *)

    consknt := consknt + 1;
    dealloc(2);
    END;

PROCEDURE xncons;
    BEGIN r[2] := nilref;
    xcons;
    END;

PROCEDURE xxcons;
    BEGIN rxx := r[1];
    r[1] := r[2];
    r[2] := rxx;
    xcons;
    END;
(* Makes things too big for Apollo ...
PROCEDURE xWrtok;       FORWARD;

PROCEDURE err_not_pair(VAR u: itemref);
    BEGIN
    write('*****Pair operation attempted on '); xwrtok; writeln;
    mkerr(notpair, u);
    END;
*)

    (* return car of r[1] in r[1] *)
PROCEDURE xcar;
    BEGIN
    IF tag_of(r[1]) = pairtag THEN
        r[1] := prspace[info_of(r[1])].prcar
    ELSE
        mkerr(notpair, r[1]);
    END;

PROCEDURE xcdr;
    BEGIN
    IF tag_of(r[1]) = pairtag THEN
        r[1] := prspace[info_of(r[1])].prcdr
    ELSE
        mkerr(notpair, r[1]);
    END;

PROCEDURE xrplaca;
    BEGIN
    IF tag_of(r[1]) = pairtag THEN
        prspace[info_of(r[1])].prcar:=r[2]
    ELSE
        mkerr(notpair, r[1]);
    END;

PROCEDURE xrplacd;
    BEGIN
    IF tag_of(r[1]) = pairtag THEN
        prspace[info_of(r[1])].prcdr :=r[2]
    ELSE
        mkerr(notpair, r[1]);
    END;

    (* anyreg car and cdr *)
PROCEDURE anycar(a: itemref; VAR b: itemref);
    BEGIN
    IF tag_of(a) = pairtag THEN
        b := prspace[info_of(a)].prcar
    ELSE
        mkerr(notpair, b);
    END;

PROCEDURE anycdr(a: itemref; VAR b: itemref);
    BEGIN
    IF tag_of(a) = pairtag THEN
        b := prspace[info_of(a)].prcdr
    ELSE
        mkerr(notpair, b);
    END;


    (********************************************************)
    (*                                                      *)
    (*              compress & explode                      *)
    (*                                                      *)
    (********************************************************)

PROCEDURE compress;     (* returns new id from list of chars *)
      VAR i: stringp;
          clist, c: itemref;
          found: boolean;
          int: longint;

    FUNCTION is_int(i: stringp; VAR int: longint): boolean;
        VAR negative, could_be: boolean;

        BEGIN   (* is_int *)
        int := 0;
        could_be := true;
        negative := strspace[i] = '-';
        IF negative OR (strspace[i] = '+') THEN i := i + 1;

        WHILE could_be AND (strspace[i] <> eos) DO
            BEGIN
            IF (strspace[i] >= '0') AND (strspace[i] <= '9') THEN
                 int := int * 10 + (ord(strspace[i]) - ord('0'))
            ELSE could_be := false;
            i := i + 1
            END;

        IF negative THEN int := -int;
        is_int := could_be
        END     (* is_int *);

    BEGIN     (* compress *)
    clist := r[1];        (* list of chars *)
    i := freestr; (* point to possible new string *)

    WHILE (i < maxstrsp) AND NOT xNull(clist) DO
        BEGIN
        IF tag_of(clist) = PAIRTAG THEN
            BEGIN
            c := prspace[info_of(clist)].prcar;
            clist := prspace[info_of(clist)].prcdr;
            IF tag_of(c) = IDTAG THEN
                IF (info_of(c) > choffset) AND
                   (info_of(c) < choffset + 128) THEN 
                    BEGIN 
                    strspace[i] := chr(info_of(c) - choffset);
                    i := i + 1
                    END
                ELSE 
                    writeln('*****Compress: list item not single char')
            ELSE 
                writeln('*****Compress: list item not ID');
            END 
        ELSE 
            writeln('*****Compress: item not list')
        END (* WHILE *);

    strspace[i] := eos;   (* terminate string *)

    IF (i >= maxstrsp) THEN
        writeln('*****String space exhausted')
    ELSE IF is_int(freestr, int) THEN
         mkint(int, 1)
    ELSE (* look the name up, return itemref for it *)
        BEGIN
        putnm(freestr, r[1], found);
        IF NOT found THEN
            freestr := i + 1;
        END
    END       (* compress *);

PROCEDURE explode;      (* returns list of chars from id or int *)
      
      FUNCTION id_explode(i: stringp): itemref;
          BEGIN (* id_explode *)
          IF strspace[i] = eos THEN id_explode := nilref
          ELSE 
              BEGIN
              r[2] := id_explode(i + 1);
              mkident(ord(strspace[i]) + choffset, 1);
              xcons;
              id_explode := r[1]
              END
          END   (* id_explode *);

     FUNCTION int_explode(i: longint): itemref;
          VAR negative: boolean;

          BEGIN (* int_explode *)
          r[1] := nilref;
          IF i < 0 THEN
              BEGIN negative := true;
              i := -i
              END
          ELSE negative := false;

          WHILE i > 0 DO
              BEGIN
              r[2] := r[1];
              mkident(i MOD 10 + ord('0') + choffset, 1);
              xcons;
              i := i DIV 10
              END;

          IF negative THEN
              BEGIN 
              r[2] := r[1];
              mkident(ord('-') + choffset, 1);
              xcons
              END;
          int_explode := r[1]
          END (* int_explode *);

      BEGIN     (* explode *)
      IF tag_of(r[1]) = IDTAG THEN 
          r[1] := id_explode(idspace[info_of(r[1])].idname)
      ELSE IF tag_of(r[1]) = INTTAG THEN 
          r[1] := int_explode(info_of(r[1]))
      ELSE IF tag_of(r[1]) = FIXTAG THEN
          r[1] := int_explode(intspace[info_of(r[1])])
      ELSE IF tag_of(r[1]) = CODETAG THEN
          r[1] := int_explode(info_of(r[1]))
      ELSE 
          writeln('***** EXPLODE: Arg bad type')
      END       (* explode *);

PROCEDURE gensym;
    VAR i: integer;

    PROCEDURE kick(i: integer);     (* increments gsym digit *)
        BEGIN (* Kick *)
        IF (g_sym[i] = '9') THEN 
            BEGIN
            g_sym[i] := '0';
            IF (i < max_gsym) THEN kick(i + 1)  (* otherwise wrap around *)
            END
        ELSE g_sym[i] := succ(g_sym[i])
        
        END (* Kick *);

    BEGIN (* gensym *)
    r[1] := nilref;

    FOR i := 1 TO max_gsym DO
        BEGIN
        r[2] := r[1];
        mkident(ord(g_sym[i]) + choffset, 1);
        xcons
        END;
    r[2] := r[1];
    mkident(ord('G') + choffset, 1);
    xcons;
    compress;

    Kick(1);
    END; (* gensym *)


    (********************************************************)
    (*                                                      *)
    (*                    i/o primitives                    *)
    (*                                                      *)
    (********************************************************)

PROCEDURE xopen;   (* Simple OPEN, but see NPAS0 *)

var s1: FileName;
    i,j : integer;
#a  io_status: integer32;
#p (* catch some I/O errors *)
#p  handler ResetError(name: PathName);
#p  begin
#p    writeln('**** Could not open file -  ',name,' for read');
#p    exit(xopen);
#p  end;

#p  handler RewriteError(name: PathName);
#p  begin
#p    writeln('**** Could not open file -  ',name,' for write');
#p    exit(xopen);
#p  end;
  
begin
      IF tag_of(r[1]) = IDTAG THEN 
      begin
        i := idspace[info_of(r[1])].idname;
#p      s1[0] := chr(255);  (* set length *)
#d     s1:='         ';
#w     s1:="                    ";
#aptv  s1:='                                                            ';
#adpvw j:= 0;
#t     j := 1;

        WHILE (i <= maxstrsp) AND (strspace[i] <> eos) 
#d             AND (j <9 )
          do
        begin
#d      IF strspace[i] <> '.' THEN (* ignore dots in 20 file names. *)
#d      BEGIN
#d        j:= j + 1;
          s1[j] := strspace[i];
#d        END;
#aptvw    j:= j + 1;
          i:= i + 1;
        end;
#p      s1[0]:= chr(j);  (* set Actual Length *)
       
        IF tag_of(r[2]) = IDTAG THEN 
          BEGIN
           If info_of(r[2])= Xinput then
             begin 
#t              close(finput);
#twp            reset(finput, s1);
#d              reset(finput,s1,0,0,'DSK   '); 
#a              close(finput);
#a              open(finput, s1, 'old', io_status);
#a              IF io_status = 0 THEN 
#a                  BEGIN 
#a                  reset(finput);
                    mkint(4,1)
#a                  END
#a              ELSE BEGIN writeln('***** OPEN: Could not open ', s1);
#a                   r[1] := nilref END
             end

           else if info_of(r[2])= Xoutput then
             begin 
#t           close(foutput);
#twp         rewrite(foutput, s1);
#d           rewrite(foutput,s1,0,0,'DSK   '); 
#a           close(foutput);
#a           open(foutput, s1, 'new', io_status);
#a              IF io_status = 0 THEN 
#a                  BEGIN 
#a                  rewrite(foutput);
                    mkint(5,1) 
#a                  END
#a              ELSE BEGIN writeln('***** OPEN: Could not open ', s1);
#a                   r[1] := nilref
#a                   END 
             END
           ELSE
             BEGIN writeln('***** Open: arg2 not INPUT/OUTPUT');
                   mkerr(notid,r[1])
             END
         END  ELSE writeln('***** Open: arg2 bad type')
     END ELSE writeln('***** Open: arg1 bad type');
END;

PROCEDURE xclose;
begin
  case info_of(r[1]) of
        1: ;
        2: ;
        3: ;
#w      4: ;
#w      5: ;
#apt    4: close(finput);
#apt    5: close(foutput);
#d      4: break(finput);
#d      5: break(foutput);
  end;
end;

PROCEDURE xrds;
  (* Select channel for input *)        
  VAR tmp: longint;
    BEGIN
        tmp:=inchnl;
        inchnl := info_of(r[1]);
        mkint(tmp,1)
    END;

PROCEDURE Xwrs;
  (* Select channel for output *)
  VAR tmp:longint;
    BEGIN
        tmp:=outchnl;
        outchnl := info_of(r[1]);
        mkint(tmp,1)
    END;

PROCEDURE xterpri;
    BEGIN
    CASE outchnl OF
#p     3: writeln(' ');
#d     3: begin writeln(output); break(output); end;
#dp    5: begin writeln(foutput,' '); break(foutput); end;
#atw   3: writeln(output);
#atw   5: writeln(foutput);
    END (* CASE *)
    END;

 FUNCTION Int_field(I: longint): Integer;
     VAR width: integer;
         n: longint;
     BEGIN
     width := 1;
     n := 10;
     IF i < 0 THEN width := width + 1; (* For minus sign *)
     i := abs(i);
     WHILE (i >= n) AND (width < 10) DO
         BEGIN width := width + 1;
         n := n * 10
         END;
     int_field := width
     END;

PROCEDURE XwriteInt(I:integer);
    BEGIN
        CASE outchnl OF
        3: write(i: int_field(i));
        5: write(foutput, i: int_field(i));
        END     (* CASE *)
    END  (* XwriteInt *);

PROCEDURE XwriteChar(C:onechar);
    BEGIN
#adptw CASE outchnl OF
#p         3: write('  ', C);
#adtvw     3: write(C);
#p         5: write(foutput,'  ', C);
#adtvw     5: write(foutput,C);
#adptw     END        (* CASE *)
    END;

PROCEDURE xwrtok;
    (* doesn't expand escaped characters in identifier names *)
  VAR  i: integer;
  BEGIN
   IF tag_of(r[1]) = inttag THEN  XwriteInt(info_of(R[1]))
    ELSE IF tag_of(r[1]) = fixtag THEN XwriteInt(intspace[info_of(R[1])])
    ELSE IF tag_of(r[1]) = idtag THEN
         BEGIN
           i := idspace[info_of(r[1])].idname;
           WHILE (i <= maxstrsp) AND (strspace[i] <> eos) DO
                    BEGIN
                    XwriteChar(strspace[i]);
                    i:= i + 1;
                    END;
         END
(*
    ELSE IF tag_of(r[1]) = strtag THEN
        BEGIN xWriteChar('"');
        i := info_of(r[1]);
        WHILE (i <= maxstrsp) AND (strspace[i] <> eos) DO
            BEGIN
            XwriteChar(strspace[i]);
            i := i + 1;
            END;
        xWriteChar('"')
        END
*)

    ELSE IF tag_of(r[1]) = chartag THEN
           XwriteChar(chr(info_of(r[1]) - choffset))
    ELSE IF tag_of(r[1]) = errtag THEN
      Begin XwriteChar(' ');
         XwriteChar('*'); XwriteChar('*'); XwriteChar('*');
         XwriteChar(' '); XwriteChar('#'); XwriteChar(' ');
            XwriteInt(info_of(r[1]));   Xterpri;
      End
    ELSE IF tag_of(r[1]) = codetag THEN
         Begin XwriteChar(' '); XwriteChar('#'); XwriteChar('#');
               XwriteInt(info_of(r[1]));
         End
    ELSE
         Begin
         XwriteChar(' '); XwriteChar('?'); XwriteChar(' ');
            XwriteInt(tag_of(r[1]));
         XwriteChar(' '); XwriteChar('/'); XwriteChar(' ');
            XwriteInt(info_of(r[1]));
         XwriteChar(' '); XwriteChar('?'); XwriteChar(' ');
         End;
#d   break(output);  
    END;

#aptvw FUNCTION eol: boolean;
#aptvw    BEGIN
#aptvw    CASE inchnl OF
#aptvw       1:  eol := eoln(symin);
#aptvw       2:  eol := eoln(input);
#aptvw       4:  eol := eoln(finput);
#aptvw        END;
#aptvw    END;

PROCEDURE rdchnl(chnlnum: integer; VAR ch: onechar);
    BEGIN
    IF (chnlnum < 1) OR (chnlnum > inchns) THEN
     writeln('*****Bad input channel for RDCHNL', chnlnum)
    ELSE
        CASE chnlnum OF
            1:  BEGIN
            ch := symin^;  (* a little strange, but avoids  *)
            get(symin);              (* initialization problems *)
            ichrbuf[inchnl] := symin^; (* Peek ahead *)
            END;

            2:  BEGIN
#t             IF charcnt > Length(line) THEN
#t                 BEGIN
#t                 charcnt := 1;
#t                 Readln(line)
#t                 END;
#t             ch := line[charcnt];
#t             IF Length(line) > charcnt THEN
#t                 ichrbuf[inchnl] := line[charcnt + 1]
#t             ELSE ichrbuf[inchnl] := sp;
#t             charcnt := charcnt + 1
#adpvw      ch := input^;
#adpvw      get(input);
#adpvw      ichrbuf[inchnl] := input^;
            END;
         4:  begin
             ch := finput^;
             get(finput);
             ichrbuf[inchnl] := finput^;
            END;
            END;
    (* case *)
    IF idspace[xEcho].val <> nilref THEN
#aptvw  IF eol THEN BEGIN xWriteChar(ch); xTerpri END ELSE xWriteChar(ch);
#d            xWriteChar(ch);
    END;
    (* rdchnl *)

FUNCTION eofchnl: boolean;
    BEGIN
#adptvw  CASE inchnl OF
#adptvw      1:  eofchnl := eof(symin);
#adptvw      2:  eofchnl := eof(input);
#adptvw      4:  eofchnl := eof(finput);
#adptvw      END;
    END;


    (********************************************************)
    (*                                                      *)
    (*                   token scanner                      *)
    (*                                                      *)
    (********************************************************)

PROCEDURE xrdtok;
LABEL 1;

    VAR
        ch,ch1,ChangedCh: onechar;
        i: integer;
        anint: longint;
        moreid: boolean;
        found: boolean;
        negflag: integer;

    FUNCTION digit(ch: onechar): boolean;
        BEGIN
        digit := ( '0' <= ch ) AND ( ch <= '9');
        END;


    FUNCTION escalpha(VAR ch: onechar): boolean;
        (* test for alphabetic or escaped character. *)
        (* note side effect in ChangedCh.            *)
        BEGIN
        ChangedCh := Ch;
        IF ( 'A' <= ch ) AND ( ch <= 'Z') THEN
            escalpha := true
        ELSE IF ( ord('A')+32 <= ord(ch)) AND ( ord(ch) <= ord('Z')+32) THEN
               BEGIN
                 IF NOT xNull(idspace[xraise].val) THEN
                     Changedch := chr(ord(ch)-32);
                 escalpha := true;    (* lower case alphabetics *)
               END
             ELSE IF ch='!' THEN
                      BEGIN
                      rdchnl(inchnl,ch);
                      ChangedCh:=Ch;
                      escalpha := true;
                      END
                  ELSE
                      escalpha := false;
        END;

    FUNCTION alphanum(VAR ch: onechar): boolean;
        (* test if escalfa or digit *)
        VAR b: boolean;
        BEGIN
        ChangedCh:=Ch;
        b := digit(ch);
        IF NOT b THEN b := escalpha(ch);
        alphanum := b;
        END;

    FUNCTION whitesp(ch: onechar): boolean;
#d     BEGIN
#d      (* may want a faster test *)
#d      whitesp := (ch = sp) OR (ch = cr) OR (ch = lf) OR (ch = ht)
#d      OR (ch = nul);       (* null?? *)
#aptvw    VAR ascode:integer;
#aptvw    BEGIN
#aptvw        ascode:=ord(ch);
#aptvw        WHITESP := (CH = SP) OR (ascode = CR) OR (ascode = LF)
#aptvw    OR (ascode = ht) or (ascode = nul);        (* null?? *)
    END; 

    BEGIN       (* xrdtok *)
1:
    IF NOT eofchnl THEN
        REPEAT                          (* skip leading white space. *)
            rdchnl(inchnl,ch)
        UNTIL (NOT whitesp(ch)) OR eofchnl;
    IF eofchnl THEN
        mkitem(chartag, eofcode + choffset, r[1])
        (* should really return !$eof!$  *)
    ELSE
        BEGIN
        IF digit(ch) or (ch = '-') THEN
            set_tag(r[1], inttag)
        ELSE IF ch = '"' THEN set_tag(r[1], strtag)
        ELSE IF escalpha(ch) THEN
                 set_tag(r[1], idtag)
             ELSE
                 set_tag(r[1], chartag);

        CASE tag_of(r[1]) OF
            chartag:  BEGIN
                  if ch = begin_comment then
                      BEGIN
#d                    While (ch <> cr) do rdchnl(inchnl,ch);
#aptvw                While not eol do rdchnl(inchnl,ch);
                      rdchnl(inchnl, ch);
                      GOTO 1
                      END;
                  set_tag(r[1], idtag);
                  mkitem(inttag, chartype, tmpref);
                  idspace[xtoktype].val := tmpref;
                  set_info(r[1], ord(ch) + choffset);
                  END;
            inttag:   BEGIN
                 mkitem(inttag, inttype, tmpref);
                 idspace[xtoktype].val :=tmpref;
                 negflag := 1;
                 if ch = '-' then
                 begin anint := 0; negflag :=-1 end
                     else anint := ord(ch) - ord('0');
                 WHILE digit(ichrbuf[inchnl]) DO
                     BEGIN
                     rdchnl(inchnl,ch);
                     anint := 10 * anint + (ord(ch) - ord('0'))
                     END;
                 anint := negflag * anint;
                 set_info(r[1], anint)
                 END;
            idtag:    BEGIN
                mkitem(inttag, idtype, tmpref);
                idspace[xtoktype].val:=tmpref;
                i := freestr; (* point to possible new string *)
                moreid := true;
                WHILE (i < maxstrsp) AND moreid DO
                    BEGIN
                    strspace[i] := ChangedCh;
                    (* May have Case Change, etc *)
                    i:= i + 1;
                    moreid :=alphanum(ichrbuf[inchnl]);  (* PEEK ahead char *)
                    IF moreid THEN rdchnl(inchnl,ch) (* Advance readch *)
                    END;
                strspace[i] := eos;   (* terminate string *)
                IF (i >= maxstrsp) THEN
                   writeln('*****String space exhausted')
                ELSE  (* look the name up, return itemref for it *)
                    BEGIN
                    putnm(freestr, r[1], found);
                    IF NOT found THEN
                        freestr := i + 1;
                    END;
                END   (* of case idtag *);
                strtag: BEGIN
                        (* an alias for quoted identifier - special *)
                        (* characters need not be escaped.   *)
                        mkitem(inttag, idtype, tmpref);
                        idspace[xtoktype].val:=tmpref;
                        i := freestr;
                        rdchnl(inchnl, ch); (* scan past " *)
                        WHILE (ch <> '"') AND (i < maxstrsp) DO
                            BEGIN
                            strspace[i] := ch;
                            i := i + 1;
                            rdchnl(inchnl, ch);
                            END;
#adw                    strspace[i] := eos;
#ptv                    strspace[i] := chr(eos);
                        i := i + 1;
                        IF ch <> '"' THEN
                            writeln('***** String space exhausted')
                        ELSE  (* look the name up, return itemref for it *)
                            BEGIN
                            putnm(freestr, r[1], found);
                            set_tag(r[1], idtag);
			    (* must have the form ('QUOTE . id . NIL) *)
                            (* to give the effect of a quoted id.     *)
                            r[2] := nilref;
                            xcons;
                            r[2] := r[1];
                            mkident(xQuote, 1);
                            xcons;
                            IF NOT found THEN
                                freestr := i;
                            END;
                        END (* OF CASE strtag *);
            END (* of case *);
        END;
    END (* xrdtok *);

    (********************************************************)
    (*                                                      *)
    (*                    initialization                    *)
    (*                                                      *)
    (********************************************************)


PROCEDURE init;
    (* initialization procedure depends on  *)
    (* ability to load stack with constants *)
    (* from a file.                         *)
    VAR
        strptr: stringp;
#dptvw  nam: PACKED ARRAY[1..3] OF onechar;
#a      nam: PACKED ARRAY[1..4] OF onechar; (* SPL bug for Apollo *)
        (* holds 'nil', other strings? *)
        i, n: integer;
        idref: itemref;
        found: boolean;

#aptv   (* init is divided into two parts so it can compile on terak *)
    PROCEDURE init1;
        BEGIN
#t      CHARCNT := 1;
#t      LINE := '';
#t      eos := chr(nul);

        (* initialize top of stack *)
        st := 0;

        (* initialize fixnum free list *)
        FOR freeint := 1 TO maxintsp - 1 DO 
            intspace[freeint] := freeint + 1;
        intspace[maxintsp] := end_flag;
        freeint := 1;

        (* define nilref - the id, nil, is defined a little later. *)
        freeident := 1;
        mkitem(idtag, freeident, nilref);

        (* initialize pair space. *)
        FOR i := 1 TO maxpair - 1 DO      (* initialize free list. *)
            BEGIN
            prspace[i].prcar := nilref;         (* just for fun *)
            mkitem(pairtag, i + 1, prspace[i].prcdr);
            END;
        prspace[maxpair].prcar := nilref;
        prspace[maxpair].prcdr := nilref;       (* end flag *)
        freepair := 1;                  (* point to first free pair *)


        (* initialize identifier space and string space. *)
        freestr := 1;
        FOR i := 0 TO hidmax - 1 DO
            idhead[i] := nillnk;
        FOR i := 1 TO maxident DO
            BEGIN
            IF i < maxident THEN
                idspace[i].idhlink := i + 1
            ELSE    (* nil to mark the final identifier in the table. *)
                idspace[i].idhlink := nillnk;
            (* set function cells to undefined *)
            mkerr(undefined, tmpref);
            idspace[i].funcell :=tmpref;
            idspace[i].val :=tmpref;
            idspace[i].plist :=tmpref;
            END;

        (* nil must be the first identifier in the table--id #1 *)
        (* must fill in fields by hand for nilref.*)
        (* putnm can handle any later additions.  *)
        nam := 'NIL';
        strptr := freestr;
        FOR i := 1 TO 3 DO
            BEGIN
            strspace[strptr] := nam[i];
            strptr:= strptr + 1;
            END;
        strspace[strptr] := eos;
        putnm(freestr, nilref, found);
        IF NOT found THEN
            freestr := strptr + 1;

        (* make the single character ascii identifiers, except nul(=eos). *)
        FOR i := 1 TO 127  DO
            BEGIN
            strspace[freestr] := chr(i);
            strspace[freestr + 1] := eos;
            putnm(freestr, idref, found);
            IF NOT found THEN
                freestr := freestr + 2;
            IF i = ord('T') THEN
                BEGIN 
                trueref := idref;    (* returns location for 't. *)
                idspace[info_of(idref)].val := trueref (* Set T to T *)
                END
            END;

        
        (* init gensym id list *)
        FOR i := 1 TO max_gsym DO g_sym[i] := '0';

        (* clear the counters *)
        idspace[xraise].val := trueref; (* gets undone when !*RAISE is read *)
        idspace[xEcho].val := nilref;  (* prevent echo until !*ECHO is read *)
        gccount := 0;
        consknt := 0;
        END;
        (* init1 *)

    PROCEDURE init2;
        BEGIN
        (* load "symbol table" with identifiers, constants, and functions.  *)
        inchnl := 1;        (* select symbol input file. *)
        outchnl := 3;        (* select output file. *)
#p      reset(symin,'paslsp.ini');
#p      reset(input);
#p      rewrite(output);
#w      reset(symin, "paslsp.ini");
#t      reset(symin,'#5:lspini.text');
#d      reset(symin,'paslspini',0,0,'DSK   ');
#d      reset(input,'tty      ',0,0,'TTY   ');
#d      rewrite(output,'tty      ',0,0,'TTY   ');
#a      open(symin,'paslsp.ini','old',iostatus);
#a      reset(symin);
#a      for i:=1 to inchns do
#a         ichrbuf[i]:=' ';
        xrdtok;     (* get count of identifiers. *)
        IF tag_of(r[1]) <> inttag THEN
           writeln('*****Bad symbol table, integer expected at start');
        n := info_of(r[1]);
        FOR i := 1 TO n DO
            xrdtok;
        (* reading token magically loads it into id space. *)
        xrdtok;         (* look for zero terminator. *)
        IF (tag_of(r[1]) <> inttag) OR (info_of(r[1]) <> 0) THEN
          writeln('*****Bad symbol table, zero expected after identifiers');

        xrdtok;         (* count of constants  *)
        IF tag_of(r[1]) <> inttag THEN
           writeln('*****Bad symbol table, integer expected before constants');
        n := info_of(r[1]);
        alloc(n);       (* space for constants on the stack *)
        FOR i := 1 TO n DO
            BEGIN
            xread;
            stk[i] := r[1];
            END;
        xrdtok;
        IF (tag_of(r[1]) <> inttag) OR (info_of(r[1]) <> 0) THEN
         writeln('*****Bad symbol table, zero expected after constants');
        xrdtok;     (* count of functions. *)
        IF tag_of(r[1]) <> inttag THEN
           writeln('*****Bad symbol table, integer expected before functions');
        n := info_of(r[1]);
        FOR i := 1 TO n DO
            (* for each function *)
            (* store associated code *)
            BEGIN
            xrdtok;
            mkitem(codetag, i, tmpref);
            idspace[info_of(r[1])].funcell :=tmpref;
            END;
        xrdtok;
        IF (tag_of(r[1]) <> inttag) OR (info_of(r[1]) <> 0) THEN
         writeln('*****Bad symbol table, zero expected after functions');
        END;
        (* init2 *)

(*
PROCEDURE dumpids;
    VAR i, p: integer;

    BEGIN
    FOR i := 1 TO freeident - 1 DO
        BEGIN
        p := idspace[i].idname;
        write('id #', i:5, ' at', p:5, ': ');
        WHILE strspace[p] <> eos DO
            BEGIN 
            write(strspace[p]);
            p := p + 1
            END;
        write('.  Function code: ');
        writeln(INFO_OF(idspace[i].funcell)); 
        END
    END;
*)

    BEGIN       (* init *)
    init1;
    init2;
    END;
    (* init *)

    (********************************************************)
    (*                                                      *)
    (*                 arithmetic functions                 *)
    (*                                                      *)
    (********************************************************)

PROCEDURE xadd1;
    VAR i: longint;

    BEGIN
    int_val(r[1], i);
    mkint(i + 1, 1)
    END;

PROCEDURE xdifference;
    VAR i1, i2: longint;

    BEGIN
    int_val(r[1], i1);
    int_val(r[2], i2);
    mkint(i1 - i2, 1)
    END;

PROCEDURE xdivide;      (* returns dotted pair (quotient . remainder). *)
    VAR quot, rem: integer;
        i1, i2: longint;

    BEGIN
    int_val(r[1], i1);
    int_val(r[2], i2);
    IF i2 = 0 THEN writeln('*****Attempt to divide by 0 in DIVIDE')
    ELSE BEGIN mkint(i1 DIV i2, 1);
         mkint(i1 MOD i2, 2);
         END;
    xcons
    END;

PROCEDURE xgreaterp;
    VAR i1, i2: longint;

    BEGIN
    int_val(r[1], i1);
    int_val(r[2], i2);

    IF i1 > i2 THEN
        r[1] := trueref
    ELSE
        r[1] := nilref;
    END;

PROCEDURE xlessp;
    VAR i1, i2: longint;

    BEGIN
    int_val(r[1], i1);
    int_val(r[2], i2);

    IF i1 < i2 THEN
        r[1] := trueref
    ELSE
        r[1] := nilref;
    END;

PROCEDURE xminus;
    VAR i: longint;

    BEGIN
    int_val(r[1], i);
    mkint(-i, 1)
    END;

PROCEDURE xplus2;
    VAR i1, i2: longint;

    BEGIN
    int_val(r[1], i1);
    int_val(r[2], i2);
    mkint(i1 + i2, 1)
    END;

PROCEDURE xquotient;
    VAR i1, i2: longint;

    BEGIN
    int_val(r[1], i1);
    int_val(r[2], i2);
    IF i2 = 0 THEN writeln('*****Attempt to divide by 0 in QUOTIENT')
    ELSE mkint(i1 DIV i2, 1)
    END;

PROCEDURE xremainder;
    VAR i1, i2: longint;

    BEGIN
    int_val(r[1], i1);
    int_val(r[2], i2);
    IF i2 = 0 THEN writeln('*****Attempt to divide by 0 in REMAINDER')
    ELSE mkint(i1 MOD i2, 1)
    END;

PROCEDURE xtimes2;
    VAR i1, i2: longint;

    BEGIN
    int_val(r[1], i1);
    int_val(r[2], i2);
    mkint(i1 * i2, 1)
    END;
    (* xtimes2 *)


    (********************************************************)
    (*                                                      *)
    (*                    support for eval                  *)
    (*                                                      *)
    (********************************************************)


PROCEDURE execute(code: integer);
    FORWARD;

    (* Xapply(fn,arglist)-- "fn" is an operation code. *)
PROCEDURE xxapply;
    VAR
        i: integer;
        code: integer;
        tmp: itemref;
        tmpreg: ARRAY[1..maxreg] OF itemref;
    BEGIN
    code := info_of(r[1]);
    r[1] := r[2];
    i := 1;
    (* spread the arguments  *)
    WHILE NOT xNull(r[1]) AND (i <= maxreg) DO
        BEGIN
        tmp := r[1];
        xcar;
        tmpreg[i] := r[1];
        i := i + 1;
        r[1] := tmp;
        xcdr;
        END;
    WHILE i > 1 DO
        BEGIN
        i := i - 1;
        r[i] := tmpreg[i];
        END;
    execute(code);
    END;

    (*  rest of pas1...pasn follow , pasn Closes definition of Catch *)

#padtwv (* PreProcessor Version - Run  through Filter *)
#p      (* PERQ version *)
#a      (* Apollo Version *)
#d      (* DEC-20 Version *)
#t      (* Terak Version *)
#w      (* Wicat Version *)
#v      (* VAX version *)
(*********************************************************************
                                    
                PASCAL BASED MINI-LISP

 File:  PAS0.PAS - PASCAL/LISP KERNEL
 ChangeHistory:
    9 Dec 81, RO: Remove apollo specific I/O.
    1 Dec 81  RO: I/O fixes for wicat & fixnum bug
   14 Nov 81, MLG:add some PERQ updates from Voelker
   28 Oct 81, RO: GENSYM & fixnum gc
 
   All RIGHTS RESERVED
   COPYRIGHT (C) - 1981 - M. L. Griss and R. Ottenheimer
   Computer Science Department
           University of Utah

           Do Not distribute with out written consent of M. L. Griss

********************************************************************)

#t (*$S+*) (* swapping mode *)
#t (*$G+*) (* goto is legal *)

#adtvw PROGRAM pas0 ; (* (input*,output) *)
#p    PROGRAM pas0 (input,output, symin, finput,foutput);
    (************************************************************)
    (* support routines for a "lisp" machine.  uses a register  *)
    (* model with a stack for holding frames.  stack also used  *)
    (* to hold compiler generated constants.                    *)
    (* written by:                                              *)
    (*      william f. galway, martin l. griss                  *)
    (*      ralph ottenheimer                                   *)
    (* append pas1...pasn at  end                               *)
    (* -------------------------------------------------------- *)
    (* symin is input channel one--used to initialize "symbol   *)
    (* table".  input is input channel two--standard input.     *)
    (* output is output channel one--the standard output.       *)
    (* finput is file input channel three.                      *)
    (* foutput is file output channel four.                     *)
    (************************************************************)
#a (* Apollo System include files *)
#a %include '/sys/ins/base.ins.pas';
#a %include '/sys/ins/base_transition.ins.pas';
#a %include '/sys/ins/streams.ins.pas';
#a %include '/sys/ins/pgm.ins.pas';


#p imports Stream from Stream;
#p imports system from system;
#p imports io_others from io_others;
#p imports io_unit from io_unit;

    (************************************************************)

CONST
#aptv    (* for terak, perq, Apollo, vax  *)
#aptvw sp = ' '; 
#aptvw ht = 9;          (* ascii codes *)
#aptvw lf = 10;
#aptvw cr = 13; 
#aptvw nul = 0;

#d    eos = nul;      (* terminator character for strings. *)
#t    (* use eos=chr(nul)  *)
#av  eos=chr(nul) ;
#pw  eos = chr(0);        (* KLUDGE: null string *)
#adtwpv   inchns = 3;       (* number of input channels.  *)
#adtwpv   outchns = 2;      (* number of output channels. *)
    begin_comment = '%';

(* Initial symbols, needed in Kernel *)
    xtoktype  = 129;  (* slot in idspace for toktype. *)
    xbstack   = 130;  (* Bstack Pointer *)
    xthrowing = 131;  (* If throw mode *)
    xinitform = 132;  (* for restart *)
    xraise    = 133;  (* for RAISE of lc in ids *)
    Xinput    = 134;  (* For Open *)
    Xoutput   = 135;  (* For Open *)
    chartype  =  3;   (* various token types *)
    inttype  =  1;
    idtype  =  2;

    max_gsym = 4;       (* number of digits in gen'd id. *)

#dt  shift_const = 8192; (* tags and info are packed into an integer *)
#av shift_const = 4096;
#p   (* no shift const *)
#w   (* no shift const *)
    (* assumed to be at least 16 bits long.  low order 13 bits  *)
    (* are the info, top 3 are the tag.                         *)
#dt    int_offset = 4096;  (* small integers are stored 0..8191    *)
#av    int_offset = 2048;  (* small integers are stored -2048..2047 *)
#pw     int_offset = 32767; (* PERQ and WICAT items are records *)
#dt (* instead of -4096..4095 because it will pack smaller      *)
#dt (* under ucsd pascal.                                       *)

    (* the various tags - can't use a defined scalar type *)
    (* because of the lack of convertion functions.       *)
    inttag = 0;    (* info is an integer                  *)
    chartag = 1;   (* info is a character code            *)
    pairtag = 2;   (* info points to pair                 *)
    idtag = 3;     (* info points to identifier           *)
    codetag = 4;   (* info is index into a case statement *)
    (*                that calls appropriate function.    *)
    errtag = 5;    (* info is an error code - see below.  *)
    fixtag = 6;    (* info points to a full word (or      *)
    (*                longer) integer.                    *)
    flotag = 7;    (* info points to a float number.      *)

    (* error codes.  corresponding to tag = errtag.  *)
    noprspace = 1;    (* no more "pair space"--can't cons. *)
    notpair = 2;      (* a pair operation attempted on a non-pair. *)
    noidspace = 3;    (* no more free identifiers *)
    undefined = 4;    (* used to mark undefined function cells (etc?) *)
    noint = 5;        (* no free integer space after garbage collection *)
    notid = 6;

     (* data space sizes *)
#adwv    maxpair = 10000;  (* max number of pairs allowed. *)
#p       maxpair = 3700;   (* max number of pairs allowed. *)
#t       maxpair = 1000;   (* max number of pairs allowed *)
#t       maxident = 400;   (* max number of identifiers *)
#adpwv   maxident = 800;   (* max number of identifiers *)
#adpwv   maxstrsp = 4500;  (* size of string (literal) storage space. *)
#t      maxstrsp = 2000;  (* size of string (literal) storage space. *)
    maxintsp = 200;   (* max number of long integers allowed *)
#t  maxflosp = 2;     (* max number of floating numbers allowed *)
#adpwv maxflosp = 50; (* max number of floating numbers allowed *)

    hidmax = 50;      (* number of hash values for identifiers *)
    maxgcstk = 100;   (* size of garbage collection stack.    *)
    stksize = 500;    (* stack size *)
    maxreg = 15;      (* number of registers in lisp machine. *)

    eofcode = 26;     (* magic character code for eof, ascii for *)
    (*  cntrl-z.  kludge, see note in xrdtok.  *)
    choffset = 1;     (* add choffset to ascii code to get address  *)
    (* in id space for corresponding identifier.  *)
    nillnk = 0;       (* when integers are used as pointers.  *)
    end_flag = maxint;  (* marks end of fixnum space *)

    (************************************************************)

TYPE
#w   regblk_type:array[0..16] of longint;
#d   onechar = ascii;     (* for DEC *)
#aptvw    onechar = char;     (* for terak,perq,Apollo,Wicat*)
#a   real= integer32;        (* Kludge, no reals yet *)
#p   FileName= String;       (* For PERQ FileName *)
#atwv FileName=Packed ARRAY[0..8] of onechar;
#d    FileName=Packed ARRAY[1..9] of onechar;
    (* note we allow zero for id_ptr, allowing a "nil" link. *)

    stringp = 1..maxstrsp;        (* pointer into string space. *)
    id_ptr = 0..maxident;            (* pointer into id space. *)

#adtv    itemref = integer;
#pw      itemref = RECORD
#pw                tag:integer;
#pw                info:integer;
#pw                END;
    itemtype = 0..7;    (* the tags *)


    pair = PACKED RECORD
                      prcar: itemref;
                      prcdr: itemref;
        (* OLD        markflag:boolean , but wastes space *)
                  END;


#aw       ascfile = text;
#dptv    ascfile = PACKED FILE OF onechar;
#d       textfile =PACKED FILE of char;
#a      (* No PASCAL file I/O yet *)

    ident = PACKED RECORD           (* identifier *)
                       idname: stringp;
                       val: itemref;       (* value *)
                       plist: itemref;     (* property list *)
                       funcell: itemref;   (* function cell *)
                       idhlink: id_ptr;    (* hash link *)
                   END;
#dptvw   longint = integer;
#a       longint = integer; (* Should be integer32  ? *)

    (************************************************************)

VAR
    (* global information *)
    nilref, trueref, tmpref: itemref; 
    (* refers to identifiers "nil", "t", and a temp to get around bug in. *)
    (* apollo & wicat pascal *)
    initphase: integer;                (* Start up *)
#adpvw r: ARRAY[1..maxreg] OF itemref;
#t     r: ARRAY[0..maxreg] OF itemref;  (* cuts code size down *)
    rxx,ryy: itemref;

#tw  CHARCNT: INTEGER;   (* input buffer & pointer *)
#tw  LINE: STRING;

    (* "st" is the stack pointer into "stk".  it counts the number of  *)
    (* items on the stack, so it runs from zero while the stack starts *)
    (* at one.                                                         *)
    st: 0..stksize;
    stk: ARRAY[1..stksize] OF itemref;

    (* pair space *)
    prspace: PACKED ARRAY[1..maxpair] OF pair; (* all pairs stored here. *)
    freepair: integer;          (* pointer to next free pair in prspace. *)

    (* identifier space *)
    idhead: ARRAY[0..hidmax] OF id_ptr;
    idspace: PACKED ARRAY[1..maxident] OF ident;
    freeident: integer;
    g_sym: ARRAY[1..max_gsym] OF onechar;

    (* string space *)
    strspace: PACKED ARRAY[1..maxstrsp] OF onechar;
    freestr: stringp;

    (* large integer space *)
    intspace: ARRAY[1..maxintsp] OF longint;    (* use long int on terak *)
    freeint: 1..maxintsp;

    (* floating point number space *)
    flospace: ARRAY[1..maxflosp] OF real;
    freefloat: 1..maxflosp;

    (* i/o channels *)
#p  (* files declared on header *)
#adptvw    symin: ascfile;
#adptvw    finput : ascfile;
#aptvw    foutput: ascfile;
#d       foutput: textfile;
#d  input: ascfile;
#a  IoStatus:Integer32;
    inchnl: 1..inchns;      (* current input channel number  *)
    outchnl: 1..outchns;    (* current output channel number *)

    (* "current character" for each input channel.                    *)
    (* may want to include more than one character at some later date *)
    (* (for more lookahead).                                          *)
    ichrbuf: ARRAY[1..inchns] OF onechar;

    (* for collecting statistics. *)
    gccount: integer;           (* counts garbage collections *)
    (* counts from last garbage collection. *)
    consknt: integer;           (* number of times "cons" called *)



(* ........ Everything nested inside CATCH *)

#w procedure _setjmp(var regblk:regblk_type);external;
#w procedure _long_jump(var regblk:regblk_type);external;

Procedure Xcatch;  (* ----------- Outermost Procedure ----------- *)
#adv LABEL 9999;
#w  (* need to use special ASM68 procedures for Wicat *)
 var catch_stk:0..stksize;
     catch_Bstk:itemref;
#w   Catch_regs:regblk_type;

#t Procedure xeval;
#t  Forward;
PROCEDURE xread;
    FORWARD;

PROCEDURE xprint;
    FORWARD;

PROCEDURE xunbindto;
    FORWARD;

PROCEDURE xeval;
    FORWARD;

 Procedure Xthrow;
    begin (* throw value *)
        idspace[Xthrowing].val := trueref;
#dav     goto 9999
#w       _long_jump(Catch_regs);
#tp      exit(xeval)
    end (* throw *);
#p (* Special handlers *)
#p Handler CtlC;  (* ------- handle runaway aborts ------- *)

#p begin
#p    write('^C');
#p    IOKeyClear;
#p    IObeep;
#p    if initphase > 1 then Xthrow;
#p end;

    (********************************************************)
    (*                                                      *)
    (*             item selectors & constructors            *)
    (*                                                      *)
    (********************************************************)

#a (* use some SHIFTS ? *)

FUNCTION tag_of(item: itemref): itemtype;
#t       VAR gettag: PACKED RECORD
#t                   CASE boolean OF
#t                   TRUE: (i: itemref);
#t                   FALSE: (info: 0..8191;
#t                           tag: 0..7)
#t               END;

    BEGIN (* tag_of *)
#t    gettag.i := item;
#t    tag_of := gettag.tag
#adv    tag_of := item DIV shift_const;
#pw       tag_of := item.tag;
    END;
    (* tag_of *)

FUNCTION info_of(item: itemref): integer;
#t       VAR getinfo: PACKED RECORD
#t                   CASE boolean OF
#t                   TRUE: (i: itemref);
#t                   FALSE: (info: 0..8191;
#t                           tag: 0..7)
#t               END;

 BEGIN (* info_of *)
#t    getinfo.i := item;
#t    if getinfo.tag = inttag then
#t        info_of := getinfo.info - int_offset
#t    else info_of := getinfo.info
#adv  IF item DIV shift_const = inttag THEN
#adv      info_of := item MOD shift_const - int_offset
#adv  ELSE
#adv      info_of := item MOD shift_const
#pw   info_of := item.info
    END;
    (* info_of *)

FUNCTION xnull(item: itemref): boolean;
    BEGIN
    xnull := (tag_of(item) = tag_of(nilref)) AND 
             (info_of(item) = info_of(nilref))
    END;


PROCEDURE mkitem(tag: itemtype; info: longint; VAR item: itemref);
    (* do range checking on info. ints run from -4096 to +4095 *)
    (* everything else runs from 0 to 8191. ints & chars       *)
    (* contain their info, all others points into an           *)
    (* appropriate space.                                      *)

    PROCEDURE mkfixint;
        VAR nextfree: integer;

        PROCEDURE gc_int;
            VAR i: integer;
            mark_flag: PACKED ARRAY[1..maxintsp] OF boolean;


            PROCEDURE mark(u: itemref);
                BEGIN (* Mark *)
                IF tag_of(u) = pairtag THEN
                    BEGIN
                    mark(prspace[info_of(u)].prcar);
                    mark(prspace[info_of(u)].prcdr)
                    END
                ELSE IF tag_of(u) = fixtag THEN
                    mark_flag[info_of(u)] := true
                END (* Mark *);

            BEGIN (* Gc_int *)
            writeln('*** Gc int');
            FOR i := 1 TO maxintsp do   (* clear mark flags *)
                mark_flag[i] := false;

            FOR i := 1 TO st DO             (* mark from the stack *)
                Mark(stk[i]);

            FOR i := 1 TO maxident DO       (* mark from the symbol table *)
                BEGIN
                Mark(idspace[i].val);
                Mark(idspace[i].plist);
                Mark(idspace[i].funcell)        (* probably NOT necessary *)
                END;

            (* reconstruct free list *)
            FOR i := 1 TO maxintsp - 1 DO
                IF NOT mark_flag[i] THEN
                    BEGIN
                    intspace[i] := freeint;
                    freeint := i
                    END
            END (* Gc_int *);

        BEGIN (* mkfixint *)
        IF intspace[freeint] = end_flag THEN 
            gc_int;    (* garbage collect intspace *)

        IF intspace[freeint] <> end_flag THEN 
            BEGIN    (* convert to fixnum *)
            tag := fixtag;
            nextfree := intspace[freeint];
            intspace[freeint] := info;
            info := freeint;        (* since we want the pointer *)
            freeint := nextfree
            END
        ELSE
            BEGIN mkitem(errtag,noint, r[1]);
            writeln('***** Integer space exhausted')
            END
        END;
        (* mkfixint *)


    BEGIN (* mkitem *)
    IF tag = inttag THEN
#pw     BEGIN
        IF (info < -int_offset) OR (info > int_offset - 1) THEN mkfixint
#adtv   ELSE info := info + int_offset    (* info was in range so add offset *)
#pw     END
    ELSE IF tag = fixtag THEN mkfixint

         ELSE IF info < 0 THEN
                  BEGIN
                  writeln('*****MKITEM: BAD NEG');
#d                break(output); 
#dtv              halt;
#p                exit(pas0);
#a                pgm_$exit;
                  END;
    (* nothing special to do for other types *)

    (* pack tag and info into 16-bit item.   *)
#adtv    item := tag * shift_const + info
#pw      item.tag := tag;
#pw      item.info := info
    END;
    (* mkitem *)

PROCEDURE mkerr(info: longint; VAR item: itemref);
 Begin
     mkitem(errtag,info,item);
 End;


PROCEDURE set_info(VAR item: itemref; newinfo: longint);
    BEGIN (* set_info *)
    mkitem(tag_of(item), newinfo, item)
    END;
    (* set_info *)

PROCEDURE set_tag(VAR item: itemref; newtag: itemtype);
    BEGIN (* set_tag *)
    mkitem(newtag, info_of(item), item)
    END;
    (* set_tag *)

PROCEDURE mkident(id: integer; reg: integer);
    (* make identifier "id" in register "reg" *)
    BEGIN       (* mkident *)
    mkitem(idtag, id, r[reg]);
    END;
    (* mkident *)

PROCEDURE mkint(int: longint; reg: integer);
    BEGIN       (* mkint *)
    mkitem(inttag, int, r[reg]);
    END;
    (* mkint *)

PROCEDURE mkpair(pr: integer; reg: integer);
    BEGIN (* mkpair *)
    mkitem(pairtag, pr, r[reg])
    END;
    (* mkpair *)

PROCEDURE int_val(item: itemref; VAR number: longint);
    (* returns integer value of item (int or fixnum). *)
    (* must return 'number' in var parameter instead  *)
    (* of function value since long integers are not  *)
    (* a legal function type in ucsd pascal.          *)
    BEGIN (* int_val *)
    IF tag_of(item) = inttag THEN
        number := info_of(item)
    ELSE IF tag_of(item) = fixtag THEN
             number := intspace[info_of(item)]
    ELSE writeln('***** ILLEGAL DATA TYPE FOR NUMERIC OPERATION')
        (* halt or fatal error *)
    END;
    (* int_val *)


    (********************************************************)
    (*                                                      *)
    (*                  stack allocation                    *)
    (*                                                      *)
    (********************************************************)

PROCEDURE alloc(n: integer);
    BEGIN
    IF n + st <= stksize THEN
        st := n+st
    ELSE
        BEGIN
        writeln('*****LISP STACK OVERFLOW');
        writeln('     TRIED TO ALLOCATE ',n);
        writeln('     CURRENT STACK TOP IS ',st);
#d      break(output);
        END;
    END;

PROCEDURE dealloc(n: integer);
    BEGIN
    IF st - n >= 0 THEN
        st := st - n
    ELSE
        writeln('*****LISP STACK UNDERFLOW');
    END;

    (* optimized allocs *)

PROCEDURE alloc1;
    BEGIN alloc(1) END;

PROCEDURE dealloc1;
    BEGIN dealloc(1) END;

PROCEDURE alloc2;
    BEGIN alloc(2) END;

PROCEDURE dealloc2;
    BEGIN dealloc(2) END;

PROCEDURE alloc3;
    BEGIN alloc(3) END;

PROCEDURE dealloc3;
    BEGIN dealloc(3) END;


    (********************************************************)
    (*                                                      *)
    (*              support for register model              *)
    (*                                                      *)
    (********************************************************)

PROCEDURE load(reg: integer; sloc: integer);
    BEGIN
    IF sloc < 0 THEN r[reg] := r[-sloc]
    ELSE  r[reg] := stk[st-sloc];
    (* will, fix for load (pos,pos) *)
    END;

PROCEDURE store(reg: integer; sloc: integer);
    BEGIN
    stk[st-sloc] := r[reg];
    END;

    (* optimized load/store. *)
PROCEDURE load10;
    BEGIN
    load(1,0);
    END;

PROCEDURE store10;
    BEGIN
    store(1,0);
    END;

PROCEDURE storenil(sloc: integer);
    BEGIN
    stk[st-sloc] := nilref;
    END;

(* Other primitives ?? *)

    (********************************************************)
    (*                                                      *)
    (*              identifier lookup & entry               *)
    (*                                                      *)
    (********************************************************)

function nmhash(nm: stringp): integer;
    CONST
        hashc = 256;
    VAR
        i,tmp: integer;
    BEGIN
    tmp := 0;
    i := 1;     (* get hash code from first three chars of string. *)
    WHILE (i <= 3) AND (strspace[nm+i] <> eos) DO
        BEGIN
        tmp := ord(strspace[nm+i]) + hashc*tmp;
        i := i + 1;
        END;
    nmhash := abs(tmp) MOD hidmax;      (* abs because mod is screwy. *)
    END;

FUNCTION eqstr(s1,s2: stringp): boolean;
    BEGIN
    WHILE (strspace[s1] = strspace[s2]) AND (strspace[s1] <> eos) DO
        BEGIN
        s1 := s1 + 1;
        s2 := s2 + 1;
        END;
    eqstr := (strspace[s1] = strspace[s2]);
    END;

PROCEDURE nmlookup(nm: stringp; VAR found: boolean; VAR hash: integer;
                   VAR loc: itemref);
    (* lookup a name in "identifier space".                                 *)
    (* "hash" returns the hash value for the name.                          *)
    (* "loc" returns the location in the space for the (possibly new)       *)
    (* identifier.                                                          *)
    BEGIN
    hash := nmhash(nm);
    mkitem(idtag, idhead[hash], loc);
    (* default is identifier, but may be "error". *)
    (* start at appropriate hash chain. *)

    found := false;
    WHILE (info_of(loc) <> nillnk) AND (NOT found) DO
        BEGIN
        found := eqstr(nm, idspace[info_of(loc)].idname);
        IF NOT found THEN
            set_info(loc, idspace[info_of(loc)].idhlink);
        (* next id in chain *)
        END;
    IF NOT found THEN               (* find spot for new identifier *)
        BEGIN
        IF freeident=nillnk THEN    (* no more free identifiers. *)
            mkerr( noidspace, loc)
        ELSE
            BEGIN
            set_info(loc, freeident);
            freeident := idspace[freeident].idhlink;
            END;
        END;
    END;

PROCEDURE putnm(nm: stringp; VAR z: itemref; VAR found: boolean);
    (* put a new name into identifier space, or return old location *)
    (* if it's already there.                                       *)
    VAR
        tmp: ident;
        hash: integer;
    BEGIN
    nmlookup(nm, found, hash, z);
    IF (NOT found) AND (tag_of(z) = idtag) THEN
        BEGIN
        tmp.idname := nm;
        tmp.idhlink := idhead[hash];   (* put new ident at head of chain     *)
        tmp.val := nilref;             (* initialize value and property list *)
        tmp.plist := nilref;
        tmp.funcell := nilref;         (* also, the function cell *)
        idhead[hash] := info_of(z);
        idspace[info_of(z)] := tmp;
        END;
    END;

PROCEDURE xfaststat;
    (* give quick summary of statistics gathered *)
    BEGIN
          writeln('CONSES:',consknt);
          writeln('ST    :',st);
#d       break(output)
    END;


    (********************************************************)
    (*                                                      *)
    (*              the garbage collector                   *)
    (*                                                      *)
    (********************************************************)

PROCEDURE xgcollect;
    VAR
        i: integer;
        markedk: integer;   (* counts the number of pairs marked *)
        freedk: integer;    (* counts the number of pairs freed. *)
        gcstkp: 0..maxgcstk; (* note the garbage collection stack   *)
        mxgcstk: 0..maxgcstk;           (* is local to this procedure. *)
        gcstk: ARRAY[1..maxgcstk] OF integer;
        markflag: PACKED ARRAY[1..maxpair] OF boolean;
(* used not to have array here *)
        
    PROCEDURE pushref(pr: itemref);
        (* push the address of an unmarked pair, if that's what it is. *)
        BEGIN
        IF tag_of(pr) = pairtag THEN
            IF NOT markflag[info_of(pr)] THEN  (* was .markflag *)
                BEGIN
                IF gcstkp < maxgcstk THEN
                    BEGIN
                    gcstkp := gcstkp + 1;
                    gcstk[gcstkp] := info_of(pr);
                    IF gcstkp > mxgcstk THEN
                        mxgcstk := gcstkp;
                    END
                ELSE
                    BEGIN
                    writeln('*****GARBAGE STACK OVERFLOW');
#dtv                halt;
#p                  exit(pas0);
#a                pgm_$exit;
                    END;
                END;
        END;

    PROCEDURE mark;
        (* "recursively" mark pairs referred to from gcstk. gcstk is used to *)
        (* simulate recursion.                                               *)
        VAR
            prloc: integer;
        BEGIN
        WHILE gcstkp > 0 DO
            BEGIN
            prloc := gcstk[gcstkp];
            gcstkp := gcstkp - 1;
            markflag[prloc] := true;
(* OLD      prspace[prloc].markflag := true;  *)
            pushref(prspace[prloc].prcdr);
            pushref(prspace[prloc].prcar);  (* trace the car first. *)
            END;
        END;

    BEGIN       (* xgcollect *)
    writeln('***GARBAGE COLLECTOR CALLED');
#d  break(output);
    gccount := gccount + 1;          (* count garbage collections. *)
    xfaststat;   (* give summary of statistics collected *)
    consknt := 0;       (* clear out the cons counter *)
    gcstkp := 0;        (* initialize the garbage stack pointer. *)
    mxgcstk := 0;       (* keeps track of max stack depth. *)

    (* clear markflags *)
    FOR i := 1 TO maxpair DO markflag[i] := false;
    (* OLD: wasnt needed *)
    (* mark things from the "computation" stack. *)
    FOR i := 1 TO st DO
        BEGIN
        pushref(stk[i]);
        mark;
        END;
    (* mark things from identifier space. *)
    FOR i := 1 TO maxident DO
        BEGIN
        pushref(idspace[i].val);
        mark;
        pushref(idspace[i].plist);
        mark;
        pushref(idspace[i].funcell);
        mark;
        END;

    (* reconstruct free list by adding things to the head. *)
    freedk := 0;
    markedk := 0;
    FOR i:= 1 TO maxpair - 1 DO
        BEGIN
        IF markflag[i] THEN
        (* OLD: IF prspace[i].markflag THEN  *)
            BEGIN
            markedk := markedk + 1;
            markflag[i] := false
            (* OLD: prspace[i].markflag := false *)
            END
        ELSE
            BEGIN
            prspace[i].prcar := nilref;
            mkitem(pairtag, freepair, prspace[i].prcdr);
            freepair := i;
            freedk := freedk + 1
            END
        END;
    writeln(freedk,' PAIRS FREED.');
    writeln(markedk,' PAIRS IN USE.');
    writeln('MAX GC STACK WAS ',mxgcstk);
#d  break(output);
    END;
    (* xgcollect *)

    (********************************************************)
    (*                                                      *)
    (*                  lisp primitives                     *)
    (*                                                      *)
    (********************************************************)

    (* return r[1].r[2] in r[1] *)
PROCEDURE xcons;
    VAR p: integer;

    BEGIN
    (* push args onto stack, in case we need to garbage collect the *)
    (* references will be detected.                                 *)
    alloc(2);
    stk[st] := r[1];
    stk[st-1] := r[2];

    IF xNull(prspace[freepair].prcdr) THEN xgcollect;

    p := freepair;
    freepair := info_of(prspace[p].prcdr);
    prspace[p].prcar := stk[st];
    prspace[p].prcdr := stk[st - 1];
    mkpair(p, 1);       (* leave r[1] pointing at new pair. *)

    consknt := consknt + 1;
    dealloc(2);
    END;

PROCEDURE xncons;
    BEGIN r[2] := nilref;
    xcons;
    END;

PROCEDURE xxcons;
    BEGIN rxx := r[1];
    r[1] := r[2];
    r[2] := rxx;
    xcons;
    END;

    (* return car of r[1] in r[1] *)
PROCEDURE xcar;
    BEGIN
    IF tag_of(r[1]) = pairtag THEN
        r[1] := prspace[info_of(r[1])].prcar
    ELSE
        mkerr( notpair, r[1]);
    END;

PROCEDURE xcdr;
    BEGIN
    IF tag_of(r[1]) = pairtag THEN
        r[1] := prspace[info_of(r[1])].prcdr
    ELSE
        mkerr( notpair, r[1]);
    END;

PROCEDURE xrplaca;
    BEGIN
    IF tag_of(r[1]) = pairtag THEN
        prspace[info_of(r[1])].prcar:=r[2]
    ELSE
        mkerr( notpair, r[1]);
    END;

PROCEDURE xrplacd;
    BEGIN
    IF tag_of(r[1]) = pairtag THEN
        prspace[info_of(r[1])].prcdr :=r[2]
    ELSE
        mkerr( notpair, r[1]);
    END;

    (* anyreg car and cdr *)
PROCEDURE anycar(a: itemref; VAR b: itemref);
    BEGIN
    IF tag_of(a) = pairtag THEN
        b := prspace[info_of(a)].prcar
    ELSE
        mkerr( notpair, b);
    END;

PROCEDURE anycdr(a: itemref; VAR b: itemref);
    BEGIN
    IF tag_of(a) = pairtag THEN
        b := prspace[info_of(a)].prcdr
    ELSE
        mkerr( notpair, b);
    END;


    (********************************************************)
    (*                                                      *)
    (*              compress & explode                      *)
    (*                                                      *)
    (********************************************************)

PROCEDURE compress;     (* returns new id from list of chars *)
      VAR i: stringp;
          clist, c: itemref;
          found: boolean;
          int: integer;

    FUNCTION is_int(i: stringp; VAR int: longint): boolean;
        VAR negative, could_be: boolean;

        BEGIN   (* is_int *)
        int := 0;
        could_be := true;
        negative := strspace[i] = '-';
        IF negative OR (strspace[i] = '+') THEN i := i + 1;

        WHILE could_be AND (strspace[i] <> eos) DO
            BEGIN
            IF (strspace[i] >= '0') AND (strspace[i] <= '9') THEN
                 int := int * 10 + (ord(strspace[i]) - ord('0'))
            ELSE could_be := false;
            i := i + 1
            END;

        IF negative THEN int := -int;
        is_int := could_be
        END     (* is_int *);

    BEGIN     (* compress *)
    clist := r[1];        (* list of chars *)
    i := freestr; (* point to possible new string *)

    WHILE (i < maxstrsp) AND NOT xNull(clist) DO
        BEGIN
        IF tag_of(clist) = PAIRTAG THEN
            BEGIN
            c := prspace[info_of(clist)].prcar;
            clist := prspace[info_of(clist)].prcdr;
            IF tag_of(c) = IDTAG THEN
                IF (info_of(c) > choffset) AND
                   (info_of(c) < choffset + 128) THEN 
                    BEGIN 
                    strspace[i] := chr(info_of(c) - choffset);
                    i := i + 1
                    END
                ELSE 
                    writeln('*****COMPRESS: LIST ID NOT SINGLE CHAR')
            ELSE 
                writeln('*****COMPRESS: LIST ITEM NOT ID');
            END 
        ELSE 
            writeln('*****COMPRESS: ITEM NOT LIST')
        END (* WHILE *);

    strspace[i] := eos;   (* terminate string *)

    IF (i >= maxstrsp) THEN
        writeln('*****STRING SPACE EXHAUSTED')
    ELSE IF is_int(freestr, int) THEN
         mkint(int, 1)
    ELSE (* look the name up, return itemref for it *)
        BEGIN
        putnm(freestr, r[1], found);
        IF NOT found THEN
            freestr := i + 1;
        END
    END       (* compress *);

PROCEDURE explode;      (* returns list of chars from id or int *)
      
      FUNCTION id_explode(i: stringp): itemref;
          BEGIN (* id_explode *)
          IF strspace[i] = eos THEN id_explode := nilref
          ELSE 
              BEGIN
              r[2] := id_explode(i + 1);
              mkident(ord(strspace[i]) + choffset, 1);
              xcons;
              id_explode := r[1]
              END
          END   (* id_explode *);

     FUNCTION int_explode(i: integer): itemref;
          VAR negative: boolean;

          BEGIN (* int_explode *)
          r[1] := nilref;
          IF i < 0 THEN
              BEGIN negative := true;
              i := -i
              END
          ELSE negative := false;

          WHILE i > 0 DO
              BEGIN
              r[2] := r[1];
              mkident(i MOD 10 + ord('0') + choffset, 1);
              xcons;
              i := i DIV 10
              END;

          IF negative THEN
              BEGIN 
              r[2] := r[1];
              mkident(ord('-') + choffset, 1);
              xcons
              END;
          int_explode := r[1]
          END (* int_explode *);

      BEGIN     (* explode *)
      IF tag_of(r[1]) = IDTAG THEN 
          r[1] := id_explode(idspace[info_of(r[1])].idname)
      ELSE IF tag_of(r[1]) = INTTAG THEN 
          r[1] := int_explode(info_of(r[1]))
      ELSE IF tag_of(r[1]) = FIXTAG THEN
          r[1] := int_explode(intspace[info_of(r[1])])
      ELSE 
          writeln('***** EXPLODE: ARG BAD TYPE')
      END       (* explode *);

PROCEDURE gensym;
    VAR i: integer;

    PROCEDURE kick(i: integer);     (* increments gsym digit *)
        BEGIN (* Kick *)
        IF (g_sym[i] = '9') THEN 
            BEGIN
            g_sym[i] := '0';
            IF (i < max_gsym) THEN kick(i + 1)  (* otherwise wrap around *)
            END
        ELSE g_sym[i] := succ(g_sym[i])
        
        END (* Kick *);

    BEGIN (* gensym *)
    r[1] := nilref;

    FOR i := 1 TO max_gsym DO
        BEGIN
        r[2] := r[1];
        mkident(ord(g_sym[i]) + choffset, 1);
        xcons
        END;
    r[2] := r[1];
    mkident(ord('G') + choffset, 1);
    xcons;
    compress;

    Kick(1);
    END; (* gensym *)


    (********************************************************)
    (*                                                      *)
    (*                    i/o primitives                    *)
    (*                                                      *)
    (********************************************************)

PROCEDURE xopen;   (* Simple OPEN, but see NPAS0 *)

var s1: FileName;
    i,j : integer;
#p (* catch some I/O errors *)
#p  handler ResetError(name: PathName);
#p  begin
#p    writeln('**** Could not open file -  ',name,' for read');
#p    exit(xopen);
#p  end;

#p  handler RewriteError(name: PathName);
#p  begin
#p    writeln('**** Could not open file -  ',name,' for write');
#p    exit(xopen);
#p  end;
  
begin
      IF tag_of(r[1]) = IDTAG THEN 
      begin
        i := idspace[info_of(r[1])].idname;
#p      s1[0] := chr(255);  (* set length *)
#d      s1:='         ';
        j:= 0;
        WHILE (i <= maxstrsp) AND (strspace[i] <> eos) 
#d             AND (j <9 )
          do
        begin
          j:= j + 1;
          s1[j] := strspace[i];
          i:= i + 1;
        end;
#p      s1[0]:= chr(j);  (* set Actual Length *)
       
        IF tag_of(r[2]) = IDTAG THEN 
          BEGIN
           If info_of(r[2])= Xinput then
             begin 
#p              reset(finput,s1); 
#d              reset(finput,s1,0,0,'DSK   '); 
           mkint(3,1) end
           else if info_of(r[2])= Xoutput then
             begin 
#p           rewrite(foutput,s1); 
#d           rewrite(foutput,s1,0,0,'DSK   '); 
                 mkint(2,1) end
           else
             begin writeln('**** OPEN: ARG2 NOT INPUT/OUTPUT');
                   mkerr(notid,r[1])
             end
         end  else writeln('**** OPEN: ARG2 BAD TYPE')
     end else writeln('**** OPEN: ARG1 BAD TYPE');
end;

procedure xclose;

begin
  case info_of(r[1]) of
  1: ;
#d  2: break(output);
#a  3: close(finput);
#d  3: ;
#ap 4: close(foutput);
#d  4: break(foutput);
  end;
end;

PROCEDURE xrds;
  (* Select channel for input *)        
  VAR tmp: longint;
    BEGIN
        tmp:=inchnl;
        inchnl := info_of(r[1]);
        mkint(tmp,1)
    END;

PROCEDURE Xwrs;
  (* Select channel for output *)
  VAR tmp:longint;
    BEGIN
        tmp:=outchnl;
        outchnl := info_of(r[1]);
        mkint(tmp,1)
    END;

PROCEDURE xterpri;
(* need to change for multiple output channels.  *)
    BEGIN
    CASE outchnl OF
#p 1: writeln(' ');
#d 1: begin writeln(output); break(output); end;
#dp 2: begin writeln(foutput,' '); break(foutput); end;
#awtv 1: writeln(output);
#wtv 2: writeln(foutput);
    END (* CASE *)
    END;

#adv FUNCTION Int_field(I:integer):Integer;
#adv  Begin
#adv  Int_field:=2+trunc(log(abs(I)));
#adv  END;

PROCEDURE XwriteInt(I:integer);
    BEGIN
#adptw CASE outchnl OF
#p      1: write('  ', I:0);
#dv     1: If I=0 then Write('0') else write(I:Int_field(I) );
#atw    1: write(i);
#p      2: write(foutput,'  ', I:0);
#dv     2: If I=0 then Write(foutput,'0') else write(foutput,I:Int_field(I) );
#atw    2: write(foutput, i);
#adptw   END     (* CASE *)
    END  (* XwriteInt *);

PROCEDURE Xwritereal(R:real);
    BEGIN
#adtpw CASE outchnl OF
#p     1: write(' real Bug ', trunc(R));
#adtvw 1:  write(output,R);
#p     2: write(foutput,' real Bug ', trunc(R));
#dtvw 2:  write(foutput,R);
#adtpw END        (* CASE *)
    END;

PROCEDURE XwriteChar(C:onechar);
    BEGIN
#adptw CASE outchnl OF
#p         1: write('  ', C);
#adtvw     1: write(C);
#p         2: write(foutput,'  ', C);
#adtvw     2: write(foutput,C);
#adptw     END        (* CASE *)
    END;

PROCEDURE xwrtok;
    (* doesn't expand escaped characters in identifier names *)
  VAR  i: integer;
  BEGIN
   IF tag_of(r[1]) = inttag THEN  XwriteInt(info_of(R[1]))
    ELSE IF tag_of(r[1]) = fixtag THEN XwriteInt(intspace[info_of(R[1])])
    ELSE IF tag_of(r[1]) = flotag THEN XwriteReal(flospace[info_of(r[1])])
    ELSE IF tag_of(r[1]) = idtag THEN
         BEGIN
           i := idspace[info_of(r[1])].idname;
           WHILE (i <= maxstrsp) AND (strspace[i] <> eos) DO
                    BEGIN
                    XwriteChar(strspace[i]);
                    i:= i + 1;
                    END;
                END
    ELSE IF tag_of(r[1]) = chartag THEN
           XwriteChar(chr(info_of(r[1]) - choffset))
    ELSE IF tag_of(r[1]) = errtag THEN
      Begin XwriteChar(' ');
         XwriteChar('*'); XwriteChar('*'); XwriteChar('*');
         XwriteChar(' '); XwriteChar('#'); XwriteChar(' ');
            XwriteInt(info_of(r[1]));   Xterpri;
      End
    ELSE IF tag_of(r[1]) = codetag THEN
         Begin XwriteChar(' '); XwriteChar('#'); XwriteChar('#');
               XwriteInt(info_of(r[1]));
         End
    ELSE
         Begin
         XwriteChar(' '); XwriteChar('?'); XwriteChar(' ');
            XwriteInt(tag_of(r[1]));
         XwriteChar(' '); XwriteChar('/'); XwriteChar(' ');
            XwriteInt(info_of(r[1]));
         XwriteChar(' '); XwriteChar('?'); XwriteChar(' ');
         End;
#d   break(output);  
    END;

PROCEDURE rdchnl(chnlnum: integer; VAR ch: onechar);
    BEGIN
    IF (chnlnum < 1) OR (chnlnum > inchns) THEN
     writeln('*****BAD INPUT CHANNEL FOR RDCHNL',chnlnum)
    ELSE
        CASE chnlnum OF
            1:  BEGIN
#adptvw      ch := symin^;  (* a little strange, but avoids  *)
#adptvw      get(symin);              (* initialization problems *)
#adptvw      ichrbuf[inchnl] := symin^; (* Peek ahead *)
            END;

            2:  BEGIN
#tw             IF charcnt > Length(line) THEN
#tw                 BEGIN
#tw                 charcnt := 1;
#tw                 Readln(line)
#tw                 END;
#tw             ch := line[charcnt];
#tw             IF Length(line) > charcnt THEN
#tw                 ichrbuf[inchnl] := line[charcnt + 1]
#tw             ELSE ichrbuf[inchnl] := sp;
#tw             charcnt := charcnt + 1
#adpv        ch := input^;
#adpv        get(input);
#adpv        ichrbuf[inchnl] := input^;
            END;
#dp      3:  begin
#dp          ch := finput^;
#dp          get(finput);
#dp          ichrbuf[inchnl] := finput^;
#dp         END;
            END;
    (* case *)
    END;
    (* rdchnl *)

FUNCTION eofchnl: boolean;
    BEGIN
#adptvw  CASE inchnl OF
#adptvw      1:  eofchnl := eof(symin);
#adptvw      2:  eofchnl := eof(input);
#adptvw      3:  eofchnl := eof(finput);
#adptvw      END;
    END;

 FUNCTION eol: boolean;
    BEGIN
    CASE inchnl OF
        1:  eol := eoln(symin);
        2:  eol := eoln(input);
        3:  eol := eoln(finput);
        END;
    END;

    (********************************************************)
    (*                                                      *)
    (*                   token scanner                      *)
    (*                                                      *)
    (********************************************************)

PROCEDURE xrdtok;
LABEL 1;

    VAR
        ch,ch1,ChangedCh: onechar;
        i: integer;
        anint: longint;
        moreid: boolean;
        found: boolean;
        negflag: integer;

    FUNCTION digit(ch: onechar): boolean;
        BEGIN
        digit := ( '0' <= ch ) AND ( ch <= '9');
        END;


    FUNCTION escalpha(VAR ch: onechar): boolean;
        (* test for alphabetic or escaped character.                 *)
        (* note side effect in ChangedCh.                                *)
        BEGIN
        ChangedCh := Ch;
        IF ( 'A' <= ch ) AND ( ch <= 'Z') THEN
            escalpha := true
        ELSE IF ( ord('A')+32 <= ord(ch)) AND ( ord(ch) <= ord('Z')+32) THEN
               BEGIN
                 IF NOT xNull(idspace[xraise].val) THEN
                     Changedch := chr(ord(ch)-32);
                 escalpha := true;    (* lower case alphabetics *)
               END
             ELSE IF ch='!' THEN
                      BEGIN
                      rdchnl(inchnl,ch);
                      ChangedCh:=Ch;
                      escalpha := true;
                      END
                  ELSE
                      escalpha := false;
        END;

    FUNCTION alphanum(VAR ch: onechar): boolean;
        (* test if escalfa or digit *)
        VAR b: boolean;
        BEGIN
        ChangedCh:=Ch;
        b := digit(ch);
        IF NOT b THEN b := escalpha(ch);
        alphanum := b;
        END;

    FUNCTION whitesp(ch: onechar): boolean;
#d     BEGIN
#d      (* may want a faster test *)
#d      whitesp := (ch = sp) OR (ch = cr) OR (ch = lf) OR (ch = ht)
#d      OR (ch = nul);       (* null?? *)
#aptvw    VAR ascode:integer;
#aptvw    BEGIN
#aptvw        ascode:=ord(ch);
#aptvw        WHITESP := (CH = SP) OR (ascode = CR) OR (ascode = LF)
#aptvw    OR (ascode = ht) or (ascode = nul);        (* null?? *)
    END; 

        (* reads fixnums...need to read flonums too *)
    BEGIN       (* xrdtok *)
1:
    IF NOT eofchnl THEN
        REPEAT                          (* skip leading white space. *)
            rdchnl(inchnl,ch)
        UNTIL (NOT whitesp(ch)) OR eofchnl;
    IF eofchnl THEN
        mkitem(chartag, eofcode + choffset, r[1])
        (* should really return !$eof!$  *)
    ELSE
        BEGIN
        IF digit(ch) or (ch = '-') THEN
            set_tag(r[1], inttag)
        ELSE IF escalpha(ch) THEN
                 set_tag(r[1], idtag)
             ELSE
                 set_tag(r[1], chartag);

        CASE tag_of(r[1]) OF
            chartag:  BEGIN
                  if ch = begin_comment then
                      BEGIN
                      While not eol do rdchnl(inchnl,ch);
                      rdchnl(inchnl, ch);
                      GOTO 1
                      END;
                  set_tag(r[1], idtag);
                  mkitem(inttag, chartype, tmpref);
                  idspace[xtoktype].val := tmpref;
                  set_info(r[1], ord(ch) + choffset);
                  END;
            inttag:   BEGIN
                 mkitem(inttag, inttype, tmpref;
                idspace[xtoktype].val :=tmpref;
                 negflag := 1;
                 if ch = '-' then
            begin anint := 0; negflag :=-1 end
                     else anint := ord(ch) - ord('0');
                 WHILE digit(ichrbuf[inchnl]) DO
                     BEGIN
                     rdchnl(inchnl,ch);
                     anint := 10 * anint + (ord(ch) - ord('0'))
                     END;
                 anint := negflag * anint;
                 set_info(r[1], anint)
                 END;
            idtag:    BEGIN
                mkitem(inttag, idtype, tmpref);
                idspace[xtoktype].val:=tmpref;
                i := freestr; (* point to possible new string *)
                moreid := true;
                WHILE (i < maxstrsp) AND moreid DO
                    BEGIN
                    strspace[i] := ChangedCh; (* May have Case Change, etc *)
                    i:= i + 1;
                    moreid :=alphanum(ichrbuf[inchnl]);  (* PEEK ahead char *)
                    IF moreid THEN rdchnl(inchnl,ch) (* Advance readch *)
                    END;
                strspace[i] := eos;   (* terminate string *)
                IF (i >= maxstrsp) THEN
                   writeln('*****STRING SPACE EXHAUSTED')
                ELSE  (* look the name up, return itemref for it *)
                    BEGIN
                    putnm(freestr, r[1], found);
                    IF NOT found THEN
                        freestr := i + 1;
                    END;
                END;
                (* of case idtag *)
            END;
        (* of case *)
        END;
    END;
    (* xrdtok *)
    (* for DEBUG *)
    (********************************************************)
    (*                                                      *)
    (*                    initialization                    *)
    (*                                                      *)
    (********************************************************)


PROCEDURE init;
    (* initialization procedure depends on  *)
    (* ability to load stack with constants *)
    (* from a file.                         *)
    VAR
        strptr: stringp;
#dptvw  nam: PACKED ARRAY[1..3] OF onechar;
#a      nam: PACKED ARRAY[1..4] OF onechar; (* SPL bug for Apollo *)
        (* holds 'nil', other strings? *)
        i, n: integer;
        idref: itemref;
        found: boolean;

#aptv   (* init is divided into two parts so it can compile on terak *)
    PROCEDURE init1;
        BEGIN
#tw      CHARCNT := 1;
#tw      LINE := '';

        (* initialize top of stack *)
        st := 0;

        freefloat := 1;
        (* initialize fixnum free list *)
        FOR freeint := 1 TO maxintsp - 1 DO 
            intspace[freeint] := freeint + 1;
        intspace[maxintsp] := end_flag;
        freeint := 1;

        (* define nilref - the id, nil, is defined a little later. *)
        freeident := 1;
        mkitem(idtag, freeident, nilref);

        (* initialize pair space. *)
        FOR i := 1 TO maxpair - 1 DO      (* initialize free list. *)
            BEGIN
          (* OLD: prspace[i].MarkFlag := false; *)
            prspace[i].prcar := nilref;         (* just for fun *)
            mkitem(pairtag, i + 1, prspace[i].prcdr);
            END;
        prspace[maxpair].prcar := nilref;
        prspace[maxpair].prcdr := nilref;       (* end flag *)
        freepair := 1;                  (* point to first free pair *)


        (* initialize identifier space and string space. *)
        freestr := 1;
        FOR i := 0 TO hidmax - 1 DO
            idhead[i] := nillnk;
        FOR i := 1 TO maxident DO
            BEGIN
            IF i < maxident THEN
                idspace[i].idhlink := i + 1
            ELSE    (* nil to mark the final identifier in the table. *)
                idspace[i].idhlink := nillnk;
            (* set function cells to undefined *)
            mkerr( undefined, tmpref);
            idspace[i].funcell :=tmpref;
            idspace[i].val :=tmpref;
            idspace[i].plist :=tmpref;
            END;

        (* nil must be the first identifier in the table--id #1 *)
        (* must fill in fields by hand for nilref.*)
        (* putnm can handle any later additions.  *)
        nam := 'NIL';
        strptr := freestr;
        FOR i := 1 TO 3 DO
            BEGIN
            strspace[strptr] := nam[i];
            strptr:= strptr + 1;
            END;
        strspace[strptr] := eos;
        putnm(freestr, nilref, found);
        IF NOT found THEN
            freestr := strptr + 1;

        (* make the single character ascii identifiers, except nul(=eos). *)
        FOR i := 1 TO 127  DO
            BEGIN
            strspace[freestr] := chr(i);
            strspace[freestr + 1] := eos;
            putnm(freestr, idref, found);
            IF NOT found THEN
                freestr := freestr + 2;
            IF i = ord('T') THEN
                trueref := idref;
            (* returns location for 't. *)
            END;

        (* init gensym id list *)
        FOR i := 1 TO max_gsym DO g_sym[i] := '0';

        (* clear the counters *)
        idspace[xraise].val := trueref;
        gccount := 0;
        consknt := 0;
        END;
        (* init1 *)

    PROCEDURE init2;
        BEGIN
        (* load "symbol table" with identifiers, constants, and functions.  *)
        inchnl := 1;        (* select symbol input file. *)
        outchnl := 1;        (* select symbol OUTPUT file. *)
#p      reset(symin,'paslsp.ini');
#p      reset(input);
#p      rewrite(output);
#w      reset(symin, "paslsp.ini");
#t      reset(symin,'#5:poly.data');
#d      reset(symin,'paslspini',0,0,'DSK   ');
#d      reset(input,'tty      ',0,0,'TTY   ');
#d      rewrite(output,'tty      ',0,0,'TTY   ');
#a      open(symin,'paslsp.ini','old',iostatus);
#a      reset(symin);
#a      for i:=1 to inchns do
#a       BEGIN;
#a         ichrbuf[i]:=' ';
#a       END;
        xrdtok;     (* get count of identifiers. *)
        IF tag_of(r[1]) <> inttag THEN
           writeln('*****BAD SYMBOL TABLE, INTEGER EXPECTED AT START');
        n := info_of(r[1]);
        FOR i := 1 TO n DO
            xrdtok;
        (* reading token magically loads it into id space. *)
        xrdtok;         (* look for zero terminator. *)
        IF (tag_of(r[1]) <> inttag) OR (info_of(r[1]) <> 0) THEN
          writeln('*****BAD SYMBOL TABLE, ZERO EXPECTED AFTER IDENTIFIERS');

        xrdtok;         (* count of constants  *)
        IF tag_of(r[1]) <> inttag THEN
           writeln('*****BAD SYMBOL TABLE, INTEGER EXPECTED BEFORE CONSTANTS');
        n := info_of(r[1]);
        alloc(n);       (* space for constants on the stack *)
        FOR i := 1 TO n DO
            BEGIN
            xread;
            stk[i] := r[1];
            END;
        xrdtok;
        IF (tag_of(r[1]) <> inttag) OR (info_of(r[1]) <> 0) THEN
         writeln('*****BAD SYMBOL TABLE, ZERO EXPECTED AFTER CONSTANTS');
        xrdtok;     (* count of functions. *)
        IF tag_of(r[1]) <> inttag THEN
           writeln('*****BAD SYMBOL TABLE, INTEGER EXPECTED BEFORE FUNCTIONS');
        n := info_of(r[1]);
        FOR i := 1 TO n DO
            (* for each function *)
            (* store associated code *)
            BEGIN
            xrdtok;
            mkitem(codetag, i, tmpref);
            idspace[info_of(r[1])].funcell :=tmpref;
            END;
        xrdtok;
        IF (tag_of(r[1]) <> inttag) OR (info_of(r[1]) <> 0) THEN
         writeln('*****BAD SYMBOL TABLE, ZERO EXPECTED AFTER FUNCTIONS');
        END;
        (* init2 *)

PROCEDURE dumpids;
    VAR i, p: integer;

    BEGIN
    FOR i := 1 TO freeident - 1 DO
        BEGIN
        p := idspace[i].idname;
        write('id #', i:5, ' at', p:5, ': ');
        WHILE strspace[p] <> eos DO
            BEGIN 
            write(strspace[p]);
            p := p + 1
            END;
        write('.  Function code: ');
        writeln(INFO_OF(idspace[i].funcell)); 
        END
    END;

    BEGIN       (* init *)
    init1;
    init2;
    END;
    (* init *)

    (********************************************************)
    (*                                                      *)
    (*                 arithmetic functions                 *)
    (*                                                      *)
    (********************************************************)

PROCEDURE xadd1;
    VAR i: longint;

    BEGIN
    int_val(r[1], i);
    mkint(i + 1, 1)
    END;

PROCEDURE xdifference;
    VAR i1, i2: longint;

    BEGIN
    int_val(r[1], i1);
    int_val(r[2], i2);
    mkint(i1 - i2, 1)
    END;

PROCEDURE xdivide;      (* returns dotted pair (quotient . remainder). *)
    VAR quot, rem: integer;
        i1, i2: longint;

    BEGIN
    int_val(r[1], i1);
    int_val(r[2], i2);

    mkint(i1 DIV i2, 1);
    mkint(i1 MOD i2, 2);
    xcons
    END;

PROCEDURE xgreaterp;
    VAR i1, i2: longint;

    BEGIN
    int_val(r[1], i1);
    int_val(r[2], i2);

    IF i1 > i2 THEN
        r[1] := trueref
    ELSE
        r[1] := nilref;
    END;

PROCEDURE xlessp;
    VAR i1, i2: longint;

    BEGIN
    int_val(r[1], i1);
    int_val(r[2], i2);

    IF i1 < i2 THEN
        r[1] := trueref
    ELSE
        r[1] := nilref;
    END;

PROCEDURE xminus;
    VAR i: longint;

    BEGIN
    int_val(r[1], i);
    mkint(-i, 1)
    END;

PROCEDURE xplus2;
    VAR i1, i2: longint;

    BEGIN
    int_val(r[1], i1);
    int_val(r[2], i2);
    mkint(i1 + i2, 1)
    END;

PROCEDURE xquotient;
    VAR i1, i2: longint;

    BEGIN
    int_val(r[1], i1);
    int_val(r[2], i2);
    mkint(i1 DIV i2, 1)
    END;

PROCEDURE xremainder;
    VAR i1, i2: longint;

    BEGIN
    int_val(r[1], i1);
    int_val(r[2], i2);
    mkint(i1 MOD i2, 1)
    END;

PROCEDURE xtimes2;
    VAR i1, i2: longint;

    BEGIN
    int_val(r[1], i1);
    int_val(r[2], i2);
    mkint(i1 * i2, 1)
    END;
    (* xtimes2 *)


    (********************************************************)
    (*                                                      *)
    (*                    support for eval                  *)
    (*                                                      *)
    (********************************************************)


PROCEDURE execute(code: integer);
    FORWARD;

    (* Xapply(fn,arglist)-- "fn" is an operation code. *)
PROCEDURE xxapply;
    VAR
        i: integer;
        code: integer;
        tmp: itemref;
        tmpreg: ARRAY[1..maxreg] OF itemref;
    BEGIN
    code := info_of(r[1]);
    r[1] := r[2];
    i := 1;
    (* spread the arguments  *)
    WHILE NOT xNull(r[1]) AND (i <= maxreg) DO
        BEGIN
        tmp := r[1];
        xcar;
        tmpreg[i] := r[1];
        i := i + 1;
        r[1] := tmp;
        xcdr;
        END;
    WHILE i > 1 DO
        BEGIN
        i := i - 1;
        r[i] := tmpreg[i];
        END;
    execute(code);
    END;

    (*  rest of pas1...pasn follow , pasn Closes definition of Catch *)