Overview
Comment:Add Reduce 3.0 to the historical section of the archive, and some more
files relating to version sof PSL from the early 1980s. Thanks are due to
Paul McJones and Nelson Beebe for these, as well as to all the original
authors.

git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/historical@5328 2bfe0521-f11c-4a00-b80e-6202646ff360

Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | master | trunk
Files: files | file ages | folders
SHA3-256: eb17ceb7f6d1988541bda764091c0c13ecf308535b2adc9e12c4d1e9c85cb49f
User & Date: arthurcnorman@users.sourceforge.net on 2020-04-21 19:40:01
Other Links: manifest | tags
Context
2021-03-01
00:11:36
Updating .gitignore check-in: 4f9bfc4337 user: jeff@gridfinity.com tags: master, trunk
2020-04-21
19:40:01
Add Reduce 3.0 to the historical section of the archive, and some more
files relating to version sof PSL from the early 1980s. Thanks are due to
Paul McJones and Nelson Beebe for these, as well as to all the original
authors.

git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/historical@5328 2bfe0521-f11c-4a00-b80e-6202646ff360 check-in: eb17ceb7f6 user: arthurcnorman@users.sourceforge.net tags: master, trunk

2019-02-28
18:01:26
Commit two tar.gz files with PSL sources and binaries for "old" architectures.
Courtesy of Winfried Neun (ZIB Berlin).

git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/historical@4918 2bfe0521-f11c-4a00-b80e-6202646ff360 check-in: b5833487d7 user: schoepf@users.sourceforge.net tags: master, trunk

Changes

Added CONTRIBUTORS version [7f84b98c0f].









































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
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

 

Added perq-pascal-lisp-project/CONTRIBUTORS version [7f84b98c0f].









































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
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

 

Added perq-pascal-lisp-project/[teco].output version [c35b8bf16a].





























































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
@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

Added perq-pascal-lisp-project/apollo-paslsp.aux version [6215f4ba3d].

















>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
@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;;)}

Added perq-pascal-lisp-project/apollo-paslsp.err version [507cbceb11].











>
>
>
>
>
1
2
3
4
5
@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 ")".

Added perq-pascal-lisp-project/apollo-paslsp.lpt version [5a2f0fef1c].

















































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
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

Added perq-pascal-lisp-project/apollo-paslsp.mss version [960b88068d].























































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
@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)

Added perq-pascal-lisp-project/apollo-paslsp.otl version [e310cc6bc0].







































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
@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
-----------------------------------------------------------------------------

Added perq-pascal-lisp-project/appendix-a.table version [fc4fc16be9].

















































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
@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

Added perq-pascal-lisp-project/componly.bld version [555d07e63d].













>
>
>
>
>
>
1
2
3
4
5
6
pascal
s:PL20.rel
S:PL20.lst
S:PL20.PAS/debug
load S:PL20.REL
save S:PL20.EXE

Added perq-pascal-lisp-project/delete.pas version [f4ac3aa94f].

































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
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;

Added perq-pascal-lisp-project/draft version [5f78cf2721].













>
>
>
>
>
>
1
2
3
4
5
6
Subject: PASLSP TEST
To: GRISS
cc: CAI.OTTENHEIMER

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

Added perq-pascal-lisp-project/exec.pas version [c3841c4d21].

cannot compute difference between binary files

Added perq-pascal-lisp-project/lspfns.pas version [2044c66832].























































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
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;

Added perq-pascal-lisp-project/lspker.pas version [75f18e93af].











































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
(* 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. *??*)

Added perq-pascal-lisp-project/pas0.perq version [2651cb233d].



































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505

 (* 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;

Added perq-pascal-lisp-project/pas0.pre version [3176d56a5a].























































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
#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 *)

Added perq-pascal-lisp-project/pas0.save version [32c96d71fe].

































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
#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 *)

Added perq-pascal-lisp-project/pas0.sym version [efa6eea900].















































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
PAS0IDS := '((TOKTYPE . 129)
             (BSTK!* . 130)
             (THROWING!* . 131)
             (INITFORM!* . 132)
             (!*RAISE    . 133)
	     (INPUT      . 134)
             (OUTPUT     . 135)
             (!*ECHO     . 137)
            )$
PAS0CSTS := '()$
PAS0LITS := '()$

% Functions that initial system is expected to know about.
% (Arranged in alphabetical order.)
PAS0FNS:='(
(!*FIRST!-PROCEDURE . FIRSTP)
	(ADD1 . XADD1)
	(XAPPLY . XXAPPLY)
	(CAR . XCAR)
        (CATCH . XCATCH)
	(CDR . XCDR)
	(CODEP . XCODEP)
	(COMPRESS . COMPRESS)
	(CONS . XCONS)
        (CLOSE . XCLOSE)
	(DIFFERENCE . XDIFFERENCE)
	(DIVIDE . XDIVIDE)
        (EVAL . XEVAL)
	(EXPLODE . EXPLODE)
	(FASTSTAT . XFASTSTAT)
	(GENSYM . GENSYM)
	(GREATERP . XGREATERP)
	(LESSP . XLESSP)
	(MINUS . XMINUS)
	(NCONS . XNCONS)
        (OPEN . XOPEN)
	(PLUS2 . XPLUS2)
        (PRINT . XPRINT)
	(QUOTIENT . XQUOTIENT)
	(RDTOK . XRDTOK)
        (RDS   . XRDS)
	(READ . XREAD)
	(RECLAIM . XGCOLLECT)
	(REMAINDER . XREMAINDER)
	(RPLACA . XRPLACA)
	(RPLACD . XRPLACD)
	(TERPRI . XTERPRI)
	(TIMES2 . XTIMES2)
        (THROW  . XTHROW)
        (UNBINDTO . XUNBINDTO)
	(WRTOK . XWRTOK)
        (WRS .   XWRS)
	(XCONS . XXCONS)
	)
$

Added perq-pascal-lisp-project/pas1.bld version [d97bc1bd46].



























































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
DEF s: <SCRATCH>
DEF DSK: DSK:,SYS:
DEF SYS: DSK:,SYS:
pas:PASCMP
OFF SYSLISP$
OFF MSG$
OFF NOUUO$
ON DOMOVE$
ON NOFIXFRM;
ON MACECHO$		%OFF cuts down size of output file.
PUT('CAR,'ANYREG,'T)$
PUT('CDR,'ANYREG,'T)$

IN PAS0.SYM$		% Pre Symbol Table
OUT PAS1.PAS$
DRT1('PAS1,PAS0IDS,PAS0CSTS,PAS0LITS,PAS0FNS)$
IN PAS1.RED$
DRT2()$
SHUT PAS1.PAS$

OUT PAS1.SYM$		% Post SYMBOL Table
DUMPSYMS('PAS1)$
SHUT PAS1.SYM$

OUT PAS1.SLI$	 % Sexpressions and declarations
DRT3()$
SHUT PAS1.SLI$
QUIT$

Added perq-pascal-lisp-project/pas1.pas version [fd17de7681].

cannot compute difference between binary files

Added perq-pascal-lisp-project/pas1.red version [6adb70eef6].















































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%                                     
% 		PASCAL BASED MINI-LISP
%
% File: 	PAS1.RED - Basic I/O Functions
% ChangeDate: 	10:48pm  Wednesday, 15 July 1981
% By: 		M. L. Griss
%       	Change to add Features for Schlumberger Demo
% 
% 	    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
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

% Additional Support procedures for optimized code;

SYMBOLIC PROCEDURE CAAR(X);
 CAR CAR X;

SYMBOLIC PROCEDURE CADR X;
 CAR CDR X;

SYMBOLIC PROCEDURE CDAR X;
 CDR CAR X;

SYMBOLIC PROCEDURE CDDR X;
 CDR CDR X;

% All Friendly CxxxR's

SYMBOLIC PROCEDURE CAAAAR X; CAR CAR CAR CAR X;

SYMBOLIC PROCEDURE CAAADR X; CAR CAR CAR CDR X;

SYMBOLIC PROCEDURE CAADAR X; CAR CAR CDR CAR X;

SYMBOLIC PROCEDURE CAADDR X; CAR CAR CDR CDR X;

SYMBOLIC PROCEDURE CADAAR X; CAR CDR CAR CAR X;

SYMBOLIC PROCEDURE CADADR X; CAR CDR CAR CDR X;

SYMBOLIC PROCEDURE CADDAR X; CAR CDR CDR CAR X;

SYMBOLIC PROCEDURE CADDDR X; CAR CDR CDR CDR X;

SYMBOLIC PROCEDURE CDAAAR X; CDR CAR CAR CAR X;

SYMBOLIC PROCEDURE CDAADR X; CDR CAR CAR CDR X;

SYMBOLIC PROCEDURE CDADAR X; CDR CAR CDR CAR X;

SYMBOLIC PROCEDURE CDADDR X; CDR CAR CDR CDR X;

SYMBOLIC PROCEDURE CDDAAR X; CDR CDR CAR CAR X;

SYMBOLIC PROCEDURE CDDADR X; CDR CDR CAR CDR X;

SYMBOLIC PROCEDURE CDDDAR X; CDR CDR CDR CAR X;

SYMBOLIC PROCEDURE CDDDDR X; CDR CDR CDR CDR X;

SYMBOLIC PROCEDURE CAAAR X; CAR CAR CAR X;

SYMBOLIC PROCEDURE CAADR X; CAR CAR CDR X;

SYMBOLIC PROCEDURE CADAR X; CAR CDR CAR X;

SYMBOLIC PROCEDURE CADDR X; CAR CDR CDR X;

SYMBOLIC PROCEDURE CDAAR X; CDR CAR CAR X;

SYMBOLIC PROCEDURE CDADR X; CDR CAR CDR X;

SYMBOLIC PROCEDURE CDDAR X; CDR CDR CAR X;

SYMBOLIC PROCEDURE CDDDR X; CDR CDR CDR X;

symbolic procedure prin2(x);
    begin
        if pairp(x) then
        <<  wrtok( '!( );
            while pairp(x) do
            <<  prin2 car(x);
                x := cdr x;
		if not eq(x,NIL) then wrtok('! ); % A space.
            >>;
            if not eq(x,NIL) then
            <<  wrtok( '!.!  ); %Period followed by space.
                prin2(x);
            >>;
            wrtok( '!) );
        >>
        else
            wrtok(x);
    end;

symbolic procedure revx(l1,l2);
   % Non-destructive reverser, adds reverse of l1 to front of l2.
    begin
        while pairp(l1) do
        <<  l2 := (car l1).l2;
            l1 := cdr l1;
        >>;
        if not null (l1) then l2 := l1 . l2;
        return l2;
    end;

symbolic procedure rev(l1);
     revx(l1,NIL);

% EOF code is Ascii Z plus an offset of 1,  much too obscure!.
symbolic procedure eofp(x);
     if atom(x) and (!*inf(x) eq 27) then 'T else 'NIL;

symbolic procedure read();
    begin scalar itm,ii;
        itm := rdtok(); 
	if not(toktype eq 3) or eofp(itm)  then return(itm); % Over cautious;
        if (itm eq '!( ) 
            then return rlist()
        else if (itm eq '!' )         % Treat quote mark as QUOTE.
	    then return <<ii := read();
			  if eofp(ii) then ii
			   else ('QUOTE . ii . NIL)>>
        else return itm;
    end;

symbolic procedure rlist();
% Non destructive READ of S-expr, including ".".
    begin scalar itm,lst,done,last;
        itm := read();
        if eofp(itm) then return itm;
	done := NIL;
        while not done do
	    if itm eq '!) and toktype eq 3 
                  then done :='T
              else if itm = '!. and toktype eq 3 
	          then <<done:='T; last:= car rlist()>>  %CAR cures bug? WFG
              else
	          <<lst := itm.lst; itm := read()>>;
% ???   if pairp last then last:=car last>>;
     	if eofp(itm) then return itm;
        return revx(lst,last);
    end;

END$

Added perq-pascal-lisp-project/pas1.sli version [5b899bf610].



>
1
% Initialization LISP for module: PAS1

Added perq-pascal-lisp-project/pas1.sym version [9d9c249db1].

cannot compute difference between binary files

Added perq-pascal-lisp-project/pas2.bld version [06d1a89250].























































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
DEF s: <SCRATCH>
DEF DSK: DSK:,SYS:
DEF SYS: DSK:,SYS:
pas:PASCMP
OFF SYSLISP$
OFF MSG$
OFF NOUUO$
OFF DOMOVE$             % Can't have BOTH DOMOVE and FXFRM
OFF NOFIXFRM;		% Reduce ALLOCS
ON MACECHO$		%OFF Cuts down size of output file.
REMPROP('W,'STAT);
REMPROP('PLIST,'STAT);

IN PAS1.SYM$
% Perhaps the following lines should really be in POLY.RED, but they
% don't work correctly inside body of text being compiled.
PUT('CAR,'ANYREG,'T)$
PUT('CDR,'ANYREG,'T)$
PUT('VALUE,'OPENCOD,'("        R[1] := idspace[info_of(R[1])].val;"));
PUT('PLIST,'OPENCOD,'("        R[1] := idspace[Info_of(r[1])].plist;"));
PUT('FUNCELL,'OPENCOD,'("        R[1] := idspace[Info_of(r[1])].funcell;"));
PUT('SETVALUE,'OPENCOD,'("       idspace[Info_of(r[1])].val := R[2];"));
PUT('SETPLIST,'OPENCOD,'("        idspace[Info_of(r[1])].plist := R[2];"));
PUT('SETFUNCELL,'OPENCOD,'("        idspace[Info_of(r[1])].funcell := R[2];"));
PUT('CHAR2ID,'OPENCOD,'("     set_tag(R[1], idtag);"));
PUT('CODEP, 'OPENCOD, '("     tag_of(r[1]) = codetag;"));

OUT PAS2.PAS$
DRT1('PAS2,PAS1IDS,PAS1CSTS,PAS1LITS,PAS1FNS)$
IN PAS2.RED$

DRT2()$
SHUT PAS2.PAS$

OUT PAS2.SYM$
DUMPSYMS('PAS2)$
SHUT PAS2.SYM$

OUT PAS2.SLI$
DRT3()$			% S-expressions and Declarations
SHUT PAS2.SLI$

QUIT$

Added perq-pascal-lisp-project/pas2.pas version [9d209a1c1c].









































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
(* %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  PASCAL Based MINI-LISP/ compilation: V1
   Special Schlumberger Demo 
   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
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% *)
(* !(!*ENTRY PAIRP EXPR !1!) *)
(*  EXPR PAIRP *)
procedure PAS21;
label
      101,
      100;
begin
(* !(!*ALLOC !0!) *)
(* !(!*JUMPNC G!0!0!0!5 !1 PAIRTAG!) *)
      IF tag_of(R[1]) <> PAIRTAG THEN GOTO 100;
(* !(!*LOAD !1 !(QUOTE T!)!) *)
      R[1] := trueref;
(* !(!*JUMP G!0!0!0!6!) *)
      GOTO 101;
(* !(!*LBL G!0!0!0!5!) *)
100: 
(* !(!*LOAD !1 !(QUOTE NIL!)!) *)
      R[1] := nilref;
(* !(!*LBL G!0!0!0!6!) *)
101: 
(* !(!*DEALLOC !0!) *)
(* !(!*EXIT!) *)
end;
procedure PAS22;
forward;
(* !(!*ENTRY NOT EXPR !1!) *)
(*  EXPR NOT *)
procedure PAS23;
begin
(* !(!*ALLOC !0!) *)
(* !(!*LOAD !2 !(QUOTE NIL!)!) *)
      R[2] := nilref;
(* !(!*LINK EQ EXPR !2!) *)
     PAS22;
(* !(!*DEALLOC !0!) *)
(* !(!*EXIT!) *)
end;
(* !(!*ENTRY CODEP EXPR !1!) *)
(*  EXPR CODEP *)
procedure XCODEP;
label
      101,
      100;
begin
(* !(!*ALLOC !0!) *)
(* !(!*JUMPNC G!0!0!1!0 !1 CODETAG!) *)
      IF tag_of(R[1]) <> CODETAG THEN GOTO 100;
(* !(!*LOAD !1 !(QUOTE T!)!) *)
      R[1] := trueref;
(* !(!*JUMP G!0!0!1!1!) *)
      GOTO 101;
(* !(!*LBL G!0!0!1!0!) *)
100: 
(* !(!*LOAD !1 !(QUOTE NIL!)!) *)
      R[1] := nilref;
(* !(!*LBL G!0!0!1!1!) *)
101: 
(* !(!*DEALLOC !0!) *)
(* !(!*EXIT!) *)
end;
procedure PAS24;
forward;
procedure PAS25;
forward;
(* !(!*ENTRY CONSTANTP EXPR !1!) *)
(*  EXPR CONSTANTP *)
procedure PAS26;
label
      100;
begin
(* !(!*ALLOC !1!) *)
    alloc1;
(* !(!*STORE !1 !0!) *)
      store10;
(* !(!*LINK PAIRP EXPR !1!) *)
     PAS21;
(* !(!*JUMPT G!0!0!1!3!) *)
      IF R[1] <> nilref THEN GOTO 100;
(* !(!*LOAD !1 !0!) *)
      load10;
(* !(!*LINK IDP EXPR !1!) *)
     PAS24;
(* !(!*LBL G!0!0!1!3!) *)
100: 
(* !(!*LINK NULL EXPR !1!) *)
     PAS25;
(* !(!*DEALLOC !1!) *)
      dealloc1;
(* !(!*EXIT!) *)
end;
(* !(!*ENTRY EQN EXPR !2!) *)
(*  EXPR EQN *)
procedure PAS27;
begin
(* !(!*ALLOC !0!) *)
(* !(!*LINK EQ EXPR !2!) *)
     PAS22;
(* !(!*DEALLOC !0!) *)
(* !(!*EXIT!) *)
end;
(* !(!*ENTRY LIST!2 EXPR !2!) *)
(*  EXPR LIST2 *)
procedure PAS28;
begin
(* !(!*ALLOC !1!) *)
    alloc1;
(* !(!*STORE !1 !0!) *)
      store10;
(* !(!*LOAD !1 !2!) *)
      R[1] := R[2];
(* !(!*LINK NCONS EXPR !1!) *)
     XNCONS;
(* !(!*LOAD !2 !0!) *)
      load(2,0);
(* !(!*LINK XCONS EXPR !2!) *)
     XXCONS;
(* !(!*DEALLOC !1!) *)
      dealloc1;
(* !(!*EXIT!) *)
end;
(* !(!*ENTRY LIST!3 EXPR !3!) *)
(*  EXPR LIST3 *)
procedure PAS29;
begin
(* !(!*ALLOC !2!) *)
    alloc2;
(* !(!*STORE !1 !0!) *)
      store10;
(* !(!*STORE !2 !-!1!) *)
      store(2,1);
(* !(!*LOAD !2 !3!) *)
      R[2] := R[3];
(* !(!*LOAD !1 !-!1!) *)
      load(1,1);
(* !(!*LINK LIST!2 EXPR !2!) *)
     PAS28;
(* !(!*LOAD !2 !0!) *)
      load(2,0);
(* !(!*LINK XCONS EXPR !2!) *)
     XXCONS;
(* !(!*DEALLOC !2!) *)
      dealloc2;
(* !(!*EXIT!) *)
end;
(* !(!*ENTRY LIST!4 EXPR !4!) *)
(*  EXPR LIST4 *)
procedure PAS210;
begin
(* !(!*ALLOC !3!) *)
    alloc3;
(* !(!*STORE !1 !0!) *)
      store10;
(* !(!*STORE !2 !-!1!) *)
      store(2,1);
(* !(!*STORE !3 !-!2!) *)
      store(3,2);
(* !(!*LOAD !3 !4!) *)
      R[3] := R[4];
(* !(!*LOAD !2 !-!2!) *)
      load(2,2);
(* !(!*LOAD !1 !-!1!) *)
      load(1,1);
(* !(!*LINK LIST!3 EXPR !3!) *)
     PAS29;
(* !(!*LOAD !2 !0!) *)
      load(2,0);
(* !(!*LINK XCONS EXPR !2!) *)
     XXCONS;
(* !(!*DEALLOC !3!) *)
      dealloc3;
(* !(!*EXIT!) *)
end;
(* !(!*ENTRY LIST!5 EXPR !5!) *)
(*  EXPR LIST5 *)
procedure PAS211;
begin
(* !(!*ALLOC !4!) *)
    alloc(4);
(* !(!*STORE !1 !0!) *)
      store10;
(* !(!*STORE !2 !-!1!) *)
      store(2,1);
(* !(!*STORE !3 !-!2!) *)
      store(3,2);
(* !(!*STORE !4 !-!3!) *)
      store(4,3);
(* !(!*LOAD !4 !5!) *)
      R[4] := R[5];
(* !(!*LOAD !3 !-!3!) *)
      load(3,3);
(* !(!*LOAD !2 !-!2!) *)
      load(2,2);
(* !(!*LOAD !1 !-!1!) *)
      load(1,1);
(* !(!*LINK LIST!4 EXPR !4!) *)
     PAS210;
(* !(!*LOAD !2 !0!) *)
      load(2,0);
(* !(!*LINK XCONS EXPR !2!) *)
     XXCONS;
(* !(!*DEALLOC !4!) *)
      dealloc(4);
(* !(!*EXIT!) *)
end;
(* !(!*ENTRY REVERSE EXPR !1!) *)
(*  EXPR REVERSE *)
procedure PAS212;
begin
(* !(!*ALLOC !0!) *)
(* !(!*LINK REV EXPR !1!) *)
     PAS131;
(* !(!*DEALLOC !0!) *)
(* !(!*EXIT!) *)
end;
(* !(!*ENTRY APPEND EXPR !2!) *)
(*  EXPR APPEND *)
procedure PAS213;
label
      101,
      100;
begin
(* !(!*ALLOC !2!) *)
    alloc2;
(* !(!*STORE !2 !-!1!) *)
      store(2,1);
(* !(!*LINK REVERSE EXPR !1!) *)
     PAS212;
(* !(!*STORE !1 !0!) *)
      store10;
(* !(!*LBL G!0!0!2!9!) *)
100: 
(* !(!*JUMPNC G!0!0!2!8 !1 PAIRTAG!) *)
      IF tag_of(R[1]) <> PAIRTAG THEN GOTO 101;
(* !(!*LOAD !2 !-!1!) *)
      load(2,1);
(* !(!*LOAD !1 !(CAR !1!)!) *)
   XCAR;
(* !(!*LINK CONS EXPR !2!) *)
     XCONS;
(* !(!*STORE !1 !-!1!) *)
      store(1,1);
(* !(!*LOAD !1 !(CDR !0!)!) *)
   ANYcdr(stk[st],R[1]);
(* !(!*STORE !1 !0!) *)
      store10;
(* !(!*JUMP G!0!0!2!9!) *)
      GOTO 100;
(* !(!*LBL G!0!0!2!8!) *)
101: 
(* !(!*LOAD !1 !-!1!) *)
      load(1,1);
(* !(!*DEALLOC !2!) *)
      dealloc2;
(* !(!*EXIT!) *)
end;
procedure PAS214;
forward;
(* !(!*ENTRY MEMBER EXPR !2!) *)
(*  EXPR MEMBER *)
procedure PAS214;
label
      102,
      101,
      100;
begin
(* !(!*ALLOC !0!) *)
(* !(!*LOAD !3 !1!) *)
      R[3] := R[1];
(* !(!*LOAD !1 !2!) *)
      R[1] := R[2];
(* !(!*JUMPT G!0!0!3!4!) *)
      IF R[1] <> nilref THEN GOTO 100;
(* !(!*LOAD !1 !3!) *)
      R[1] := R[3];
(* !(!*JUMP G!0!0!3!6!) *)
      GOTO 102;
(* !(!*LBL G!0!0!3!4!) *)
100: 
(* !(!*LOAD !1 !3!) *)
      R[1] := R[3];
(* !(!*JUMPN G!0!0!3!5 !(CAR !2!)!) *)
   ANYcar(R[2],RXX);
      IF R[1] <> RXX THEN GOTO 101;
(* !(!*LOAD !1 !2!) *)
      R[1] := R[2];
(* !(!*JUMP G!0!0!3!6!) *)
      GOTO 102;
(* !(!*LBL G!0!0!3!5!) *)
101: 
(* !(!*LOAD !2 !(CDR !2!)!) *)
   ANYcdr(R[2],R[2]);
(* !(!*LINK MEMBER EXPR !2!) *)
     PAS214;
(* !(!*LBL G!0!0!3!6!) *)
102: 
(* !(!*DEALLOC !0!) *)
(* !(!*EXIT!) *)
end;
procedure PAS215;
forward;
procedure PAS216;
forward;
(* !(!*ENTRY PAIR EXPR !2!) *)
(*  EXPR PAIR *)
procedure PAS216;
label
      103,
      102,
      101,
      100;
begin
(* !(!*ALLOC !3!) *)
    alloc3;
(* !(!*STORE !1 !0!) *)
      store10;
(* !(!*STORE !2 !-!1!) *)
      store(2,1);
(* !(!*JUMPNIL G!0!0!3!9!) *)
      IF R[1] = nilref THEN GOTO 100;
(* !(!*LOAD !1 !2!) *)
      R[1] := R[2];
(* !(!*JUMPT G!0!0!4!0!) *)
      IF R[1] <> nilref THEN GOTO 102;
(* !(!*LBL G!0!0!3!9!) *)
100: 
(* !(!*LOAD !1 !0!) *)
      load10;
(* !(!*JUMPT G!0!0!4!4!) *)
      IF R[1] <> nilref THEN GOTO 101;
(* !(!*LOAD !1 !2!) *)
      R[1] := R[2];
(* !(!*JUMPNIL G!0!0!4!5!) *)
      IF R[1] = nilref THEN GOTO 103;
(* !(!*LBL G!0!0!4!4!) *)
101: 
(* !(!*LOAD !2 !(QUOTE PAIR!)!) *)
      mkident(139,2);
(* !(!*LOAD !1 !(QUOTE !0!)!) *)
      mkint(0,1);
(* !(!*LINK ERROR EXPR !2!) *)
     PAS215;
(* !(!*LBL G!0!0!4!0!) *)
102: 
(* !(!*LOAD !2 !(CAR !1!)!) *)
   ANYcar(R[1],R[2]);
(* !(!*LOAD !1 !(CAR !0!)!) *)
   ANYcar(stk[st],R[1]);
(* !(!*LINK CONS EXPR !2!) *)
     XCONS;
(* !(!*STORE !1 !-!2!) *)
      store(1,2);
(* !(!*LOAD !2 !(CDR !-!1!)!) *)
   ANYcdr(stk[st-1],R[2]);
(* !(!*LOAD !1 !(CDR !0!)!) *)
   ANYcdr(stk[st],R[1]);
(* !(!*LINK PAIR EXPR !2!) *)
     PAS216;
(* !(!*LOAD !2 !-!2!) *)
      load(2,2);
(* !(!*LINK XCONS EXPR !2!) *)
     XXCONS;
(* !(!*LBL G!0!0!4!5!) *)
103: 
(* !(!*DEALLOC !3!) *)
      dealloc3;
(* !(!*EXIT!) *)
end;
procedure PAS217;
forward;
procedure PAS218;
forward;
(* !(!*ENTRY SASSOC EXPR !3!) *)
(*  EXPR SASSOC *)
procedure PAS218;
label
      102,
      101,
      100;
begin
(* !(!*ALLOC !3!) *)
    alloc3;
(* !(!*STORE !1 !0!) *)
      store10;
(* !(!*STORE !2 !-!1!) *)
      store(2,1);
(* !(!*STORE !3 !-!2!) *)
      store(3,2);
(* !(!*JUMPC G!0!0!4!8 !2 PAIRTAG!) *)
      IF tag_of(R[2]) = PAIRTAG THEN GOTO 100;
(* !(!*LOAD !2 !(QUOTE !(NIL!)!)!) *)
      R[2] := stk[1];
(* !(!*LOAD !1 !3!) *)
      R[1] := R[3];
(* !(!*LINK APPLY EXPR !2!) *)
     PAS217;
(* !(!*JUMP G!0!0!5!0!) *)
      GOTO 102;
(* !(!*LBL G!0!0!4!8!) *)
100: 
(* !(!*LOAD !1 !2!) *)
      R[1] := R[2];
(* !(!*LINK CAAR EXPR !1!) *)
     PAS11;
(* !(!*JUMPN G!0!0!4!9 !0!) *)
      IF R[1] <> stk[st] THEN GOTO 101;
(* !(!*LOAD !1 !(CAR !-!1!)!) *)
   ANYcar(stk[st-1],R[1]);
(* !(!*JUMP G!0!0!5!0!) *)
      GOTO 102;
(* !(!*LBL G!0!0!4!9!) *)
101: 
(* !(!*LOAD !3 !-!2!) *)
      load(3,2);
(* !(!*LOAD !2 !(CDR !-!1!)!) *)
   ANYcdr(stk[st-1],R[2]);
(* !(!*LOAD !1 !0!) *)
      load10;
(* !(!*LINK SASSOC EXPR !3!) *)
     PAS218;
(* !(!*LBL G!0!0!5!0!) *)
102: 
(* !(!*DEALLOC !3!) *)
      dealloc3;
(* !(!*EXIT!) *)
end;
procedure PAS219;
forward;
procedure PAS220;
forward;
(* !(!*ENTRY SUBLIS EXPR !2!) *)
(*  EXPR SUBLIS *)
procedure PAS220;
label
      102,
      101,
      100;
begin
(* !(!*ALLOC !3!) *)
    alloc3;
(* !(!*STORE !1 !0!) *)
      store10;
(* !(!*STORE !2 !-!1!) *)
      store(2,1);
(* !(!*JUMPC G!0!0!5!3 !1 PAIRTAG!) *)
      IF tag_of(R[1]) = PAIRTAG THEN GOTO 100;
(* !(!*LOAD !1 !2!) *)
      R[1] := R[2];
(* !(!*JUMP G!0!0!5!4!) *)
      GOTO 102;
(* !(!*LBL G!0!0!5!3!) *)
100: 
(* !(!*LOAD !2 !1!) *)
      R[2] := R[1];
(* !(!*LOAD !1 !-!1!) *)
      load(1,1);
(* !(!*LINK ASSOC EXPR !2!) *)
     PAS219;
(* !(!*JUMPNIL G!0!0!5!7!) *)
      IF R[1] = nilref THEN GOTO 101;
(* !(!*LOAD !1 !(CDR !1!)!) *)
   XCDR;
(* !(!*JUMP G!0!0!5!4!) *)
      GOTO 102;
(* !(!*LBL G!0!0!5!7!) *)
101: 
(* !(!*LOAD !1 !-!1!) *)
      load(1,1);
(* !(!*JUMPC G!0!0!5!4 !1 ATOM!) *)
      IF tag_of(R[1]) <> PAIRTAG THEN GOTO 102;
(* !(!*LOAD !2 !(CAR !1!)!) *)
   ANYcar(R[1],R[2]);
(* !(!*LOAD !1 !0!) *)
      load10;
(* !(!*LINK SUBLIS EXPR !2!) *)
     PAS220;
(* !(!*STORE !1 !-!2!) *)
      store(1,2);
(* !(!*LOAD !2 !(CDR !-!1!)!) *)
   ANYcdr(stk[st-1],R[2]);
(* !(!*LOAD !1 !0!) *)
      load10;
(* !(!*LINK SUBLIS EXPR !2!) *)
     PAS220;
(* !(!*LOAD !2 !-!2!) *)
      load(2,2);
(* !(!*LINK XCONS EXPR !2!) *)
     XXCONS;
(* !(!*LBL G!0!0!5!4!) *)
102: 
(* !(!*DEALLOC !3!) *)
      dealloc3;
(* !(!*EXIT!) *)
end;
procedure PAS221;
forward;
(* !(!*ENTRY SUBST EXPR !3!) *)
(*  EXPR SUBST *)
procedure PAS221;
label
      102,
      101,
      100;
begin
(* !(!*ALLOC !4!) *)
    alloc(4);
(* !(!*STORE !1 !0!) *)
      store10;
(* !(!*LOAD !1 !2!) *)
      R[1] := R[2];
(* !(!*JUMPNIL G!0!0!6!8!) *)
      IF R[1] = nilref THEN GOTO 102;
(* !(!*JUMPN G!0!0!6!6 !3!) *)
      IF R[1] <> R[3] THEN GOTO 100;
(* !(!*LOAD !1 !0!) *)
      load10;
(* !(!*JUMP G!0!0!6!8!) *)
      GOTO 102;
(* !(!*LBL G!0!0!6!6!) *)
100: 
(* !(!*STORE !2 !-!1!) *)
      store(2,1);
(* !(!*STORE !3 !-!2!) *)
      store(3,2);
(* !(!*JUMPNC G!0!0!6!7 !3 ATOM!) *)
      IF tag_of(R[3]) = PAIRTAG THEN GOTO 101;
(* !(!*LOAD !1 !3!) *)
      R[1] := R[3];
(* !(!*JUMP G!0!0!6!8!) *)
      GOTO 102;
(* !(!*LBL G!0!0!6!7!) *)
101: 
(* !(!*LOAD !3 !(CAR !3!)!) *)
   ANYcar(R[3],R[3]);
(* !(!*LOAD !1 !0!) *)
      load10;
(* !(!*LINK SUBST EXPR !3!) *)
     PAS221;
(* !(!*STORE !1 !-!3!) *)
      store(1,3);
(* !(!*LOAD !3 !(CDR !-!2!)!) *)
   ANYcdr(stk[st-2],R[3]);
(* !(!*LOAD !2 !-!1!) *)
      load(2,1);
(* !(!*LOAD !1 !0!) *)
      load10;
(* !(!*LINK SUBST EXPR !3!) *)
     PAS221;
(* !(!*LOAD !2 !-!3!) *)
      load(2,3);
(* !(!*LINK XCONS EXPR !2!) *)
     XXCONS;
(* !(!*LBL G!0!0!6!8!) *)
102: 
(* !(!*DEALLOC !4!) *)
      dealloc(4);
(* !(!*EXIT!) *)
end;
procedure PAS222;
forward;
(* !(!*ENTRY MEMQ EXPR !2!) *)
(*  EXPR MEMQ *)
procedure PAS222;
label
      102,
      101,
      100;
begin
(* !(!*ALLOC !0!) *)
(* !(!*JUMPNC G!0!0!7!6 !2 PAIRTAG!) *)
      IF tag_of(R[2]) <> PAIRTAG THEN GOTO 100;
(* !(!*JUMPN G!0!0!7!4 !(CAR !2!)!) *)
   ANYcar(R[2],RXX);
      IF R[1] <> RXX THEN GOTO 101;
(* !(!*LBL G!0!0!7!6!) *)
100: 
(* !(!*LOAD !1 !2!) *)
      R[1] := R[2];
(* !(!*JUMP G!0!0!7!5!) *)
      GOTO 102;
(* !(!*LBL G!0!0!7!4!) *)
101: 
(* !(!*LOAD !2 !(CDR !2!)!) *)
   ANYcdr(R[2],R[2]);
(* !(!*LINK MEMQ EXPR !2!) *)
     PAS222;
(* !(!*LBL G!0!0!7!5!) *)
102: 
(* !(!*DEALLOC !0!) *)
(* !(!*EXIT!) *)
end;
procedure PAS223;
forward;
(* !(!*ENTRY ATSOC EXPR !2!) *)
(*  EXPR ATSOC *)
procedure PAS223;
label
      103,
      102,
      101,
      100;
begin
(* !(!*ALLOC !2!) *)
    alloc2;
(* !(!*STORE !1 !0!) *)
      store10;
(* !(!*STORE !2 !-!1!) *)
      store(2,1);
(* !(!*JUMPC G!0!0!7!9 !2 PAIRTAG!) *)
      IF tag_of(R[2]) = PAIRTAG THEN GOTO 100;
(* !(!*LOAD !1 !2!) *)
      R[1] := R[2];
(* !(!*JUMP G!0!0!8!2!) *)
      GOTO 103;
(* !(!*LBL G!0!0!7!9!) *)
100: 
(* !(!*LOAD !1 !(CAR !2!)!) *)
   ANYcar(R[2],R[1]);
(* !(!*JUMPNC G!0!0!8!1 !1 PAIRTAG!) *)
      IF tag_of(R[1]) <> PAIRTAG THEN GOTO 101;
(* !(!*LOAD !1 !2!) *)
      R[1] := R[2];
(* !(!*LINK CAAR EXPR !1!) *)
     PAS11;
(* !(!*JUMPE G!0!0!8!0 !0!) *)
      IF R[1]=stk[st] THEN GOTO 102;
(* !(!*LBL G!0!0!8!1!) *)
101: 
(* !(!*LOAD !2 !(CDR !-!1!)!) *)
   ANYcdr(stk[st-1],R[2]);
(* !(!*LOAD !1 !0!) *)
      load10;
(* !(!*LINK ATSOC EXPR !2!) *)
     PAS223;
(* !(!*JUMP G!0!0!8!2!) *)
      GOTO 103;
(* !(!*LBL G!0!0!8!0!) *)
102: 
(* !(!*LOAD !1 !(CAR !-!1!)!) *)
   ANYcar(stk[st-1],R[1]);
(* !(!*LBL G!0!0!8!2!) *)
103: 
(* !(!*DEALLOC !2!) *)
      dealloc2;
(* !(!*EXIT!) *)
end;
(* !(!*ENTRY ASSOC EXPR !2!) *)
(*  EXPR ASSOC *)
procedure PAS219;
label
      103,
      102,
      101,
      100;
begin
(* !(!*ALLOC !2!) *)
    alloc2;
(* !(!*STORE !1 !0!) *)
      store10;
(* !(!*STORE !2 !-!1!) *)
      store(2,1);
(* !(!*JUMPC G!0!0!8!5 !2 PAIRTAG!) *)
      IF tag_of(R[2]) = PAIRTAG THEN GOTO 100;
(* !(!*LOAD !1 !(QUOTE NIL!)!) *)
      R[1] := nilref;
(* !(!*JUMP G!0!0!8!9!) *)
      GOTO 103;
(* !(!*LBL G!0!0!8!5!) *)
100: 
(* !(!*LOAD !1 !(CAR !2!)!) *)
   ANYcar(R[2],R[1]);
(* !(!*JUMPNC G!0!0!8!6 !1 ATOM!) *)
      IF tag_of(R[1]) = PAIRTAG THEN GOTO 101;
(* !(!*LOAD !2 !(QUOTE ASSOC!)!) *)
      mkident(140,2);
(* !(!*LOAD !1 !-!1!) *)
      load(1,1);
(* !(!*LINK LIST!2 EXPR !2!) *)
     PAS28;
(* !(!*LOAD !2 !1!) *)
      R[2] := R[1];
(* !(!*LOAD !1 !(QUOTE !1!0!0!)!) *)
      mkint(100,1);
(* !(!*LINK ERROR EXPR !2!) *)
     PAS215;
(* !(!*LBL G!0!0!8!6!) *)
101: 
(* !(!*LOAD !1 !2!) *)
      R[1] := R[2];
(* !(!*LINK CAAR EXPR !1!) *)
     PAS11;
(* !(!*JUMPN G!0!0!8!8 !0!) *)
      IF R[1] <> stk[st] THEN GOTO 102;
(* !(!*LOAD !1 !(CAR !-!1!)!) *)
   ANYcar(stk[st-1],R[1]);
(* !(!*JUMP G!0!0!8!9!) *)
      GOTO 103;
(* !(!*LBL G!0!0!8!8!) *)
102: 
(* !(!*LOAD !2 !(CDR !-!1!)!) *)
   ANYcdr(stk[st-1],R[2]);
(* !(!*LOAD !1 !0!) *)
      load10;
(* !(!*LINK ASSOC EXPR !2!) *)
     PAS219;
(* !(!*LBL G!0!0!8!9!) *)
103: 
(* !(!*DEALLOC !2!) *)
      dealloc2;
(* !(!*EXIT!) *)
end;
procedure PAS224;
forward;
procedure PAS225;
forward;
(* !(!*ENTRY DEFLIST EXPR !2!) *)
(*  EXPR DEFLIST *)
procedure PAS225;
label
      101,
      100;
begin
(* !(!*ALLOC !3!) *)
    alloc3;
(* !(!*STORE !1 !0!) *)
      store10;
(* !(!*STORE !2 !-!1!) *)
      store(2,1);
(* !(!*JUMPC G!0!0!9!2 !1 PAIRTAG!) *)
      IF tag_of(R[1]) = PAIRTAG THEN GOTO 100;
(* !(!*LOAD !1 !(QUOTE NIL!)!) *)
      R[1] := nilref;
(* !(!*JUMP G!0!0!9!3!) *)
      GOTO 101;
(* !(!*LBL G!0!0!9!2!) *)
100: 
(* !(!*LINK CAAR EXPR !1!) *)
     PAS11;
(* !(!*LOAD !3 !(CAR !(CDR !(CAR !0!)!)!)!) *)
   ANYcar(stk[st],R[3]);
   ANYcdr(R[3],R[3]);
   ANYcar(R[3],R[3]);
(* !(!*LOAD !2 !-!1!) *)
      load(2,1);
(* !(!*LINK PUT EXPR !3!) *)
     PAS224;
(* !(!*LOAD !1 !0!) *)
      load10;
(* !(!*LINK CAAR EXPR !1!) *)
     PAS11;
(* !(!*STORE !1 !-!2!) *)
      store(1,2);
(* !(!*LOAD !2 !-!1!) *)
      load(2,1);
(* !(!*LOAD !1 !(CDR !0!)!) *)
   ANYcdr(stk[st],R[1]);
(* !(!*LINK DEFLIST EXPR !2!) *)
     PAS225;
(* !(!*LOAD !2 !-!2!) *)
      load(2,2);
(* !(!*LINK XCONS EXPR !2!) *)
     XXCONS;
(* !(!*LBL G!0!0!9!3!) *)
101: 
(* !(!*DEALLOC !3!) *)
      dealloc3;
(* !(!*EXIT!) *)
end;
procedure PAS226;
forward;
procedure PAS227;
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;
procedure PAS229;
forward;
(* !(!*ENTRY DELATQ EXPR !2!) *)
(*  EXPR DELATQ *)
procedure PAS229;
label
      103,
      102,
      101,
      100;
begin
(* !(!*ALLOC !2!) *)
    alloc2;
(* !(!*STORE !1 !0!) *)
      store10;
(* !(!*STORE !2 !-!1!) *)
      store(2,1);
(* !(!*JUMPC G!0!1!1!1 !2 PAIRTAG!) *)
      IF tag_of(R[2]) = PAIRTAG THEN GOTO 100;
(* !(!*LOAD !1 !2!) *)
      R[1] := R[2];
(* !(!*JUMP G!0!1!1!5!) *)
      GOTO 103;
(* !(!*LBL G!0!1!1!1!) *)
100: 
(* !(!*LOAD !1 !(CAR !2!)!) *)
   ANYcar(R[2],R[1]);
(* !(!*JUMPNC G!0!1!1!3 !1 PAIRTAG!) *)
      IF tag_of(R[1]) <> PAIRTAG THEN GOTO 101;
(* !(!*LOAD !1 !2!) *)
      R[1] := R[2];
(* !(!*LINK CAAR EXPR !1!) *)
     PAS11;
(* !(!*JUMPE G!0!1!1!2 !0!) *)
      IF R[1]=stk[st] THEN GOTO 102;
(* !(!*LBL G!0!1!1!3!) *)
101: 
(* !(!*LOAD !2 !(CDR !-!1!)!) *)
   ANYcdr(stk[st-1],R[2]);
(* !(!*LOAD !1 !0!) *)
      load10;
(* !(!*LINK DELATQ EXPR !2!) *)
     PAS229;
(* !(!*LOAD !2 !(CAR !-!1!)!) *)
   ANYcar(stk[st-1],R[2]);
(* !(!*LINK XCONS EXPR !2!) *)
     XXCONS;
(* !(!*JUMP G!0!1!1!5!) *)
      GOTO 103;
(* !(!*LBL G!0!1!1!2!) *)
102: 
(* !(!*LOAD !1 !(CDR !-!1!)!) *)
   ANYcdr(stk[st-1],R[1]);
(* !(!*LBL G!0!1!1!5!) *)
103: 
(* !(!*DEALLOC !2!) *)
      dealloc2;
(* !(!*EXIT!) *)
end;
(* !(!*ENTRY GET EXPR !2!) *)
(*  EXPR GET *)
procedure PAS230;
label
      101,
      100;
begin
(* !(!*ALLOC !1!) *)
    alloc1;
(* !(!*STORE !2 !0!) *)
      store(2,0);
(* !(!*JUMPNC G!0!1!1!9 !1 IDTAG!) *)
      IF tag_of(R[1]) <> IDTAG THEN GOTO 100;
(* !(!*LINK PLIST EXPR !1!) *)
        R[1] := IDSPACE[INFO_OF(R[1])].PLIST;
(* !(!*LOAD !2 !1!) *)
      R[2] := R[1];
(* !(!*LOAD !1 !0!) *)
      load10;
(* !(!*LINK ATSOC EXPR !2!) *)
     PAS223;
(* !(!*JUMPNC G!0!1!1!9 !1 PAIRTAG!) *)
      IF tag_of(R[1]) <> PAIRTAG THEN GOTO 100;
(* !(!*LOAD !1 !(CDR !1!)!) *)
   XCDR;
(* !(!*JUMP G!0!1!2!1!) *)
      GOTO 101;
(* !(!*LBL G!0!1!1!9!) *)
100: 
(* !(!*LOAD !1 !(QUOTE NIL!)!) *)
      R[1] := nilref;
(* !(!*LBL G!0!1!2!1!) *)
101: 
(* !(!*DEALLOC !1!) *)
      dealloc1;
(* !(!*EXIT!) *)
end;
(* !(!*ENTRY PUT EXPR !3!) *)
(*  EXPR PUT *)
procedure PAS224;
label
      103,
      102,
      101,
      100;
begin
(* !(!*ALLOC !4!) *)
    alloc(4);
(* !(!*STORE !1 !0!) *)
      store10;
(* !(!*STORE !2 !-!1!) *)
      store(2,1);
(* !(!*STORE !3 !-!2!) *)
      store(3,2);
(* !(!*JUMPC G!0!1!2!6 !1 IDTAG!) *)
      IF tag_of(R[1]) = IDTAG THEN GOTO 100;
(* !(!*LOAD !1 !3!) *)
      R[1] := R[3];
(* !(!*JUMP G!0!1!2!4!) *)
      GOTO 103;
(* !(!*LBL G!0!1!2!6!) *)
100: 
(* !(!*LINK PLIST EXPR !1!) *)
        R[1] := IDSPACE[INFO_OF(R[1])].PLIST;
(* !(!*STORE !1 !-!3!) *)
      store(1,3);
(* !(!*LOAD !2 !1!) *)
      R[2] := R[1];
(* !(!*LOAD !1 !-!1!) *)
      load(1,1);
(* !(!*LINK ATSOC EXPR !2!) *)
     PAS223;
(* !(!*JUMPNIL G!0!1!2!8!) *)
      IF R[1] = nilref THEN GOTO 101;
(* !(!*LOAD !2 !-!3!) *)
      load(2,3);
(* !(!*LOAD !1 !-!1!) *)
      load(1,1);
(* !(!*LINK DELATQ EXPR !2!) *)
     PAS229;
(* !(!*STORE !1 !-!3!) *)
      store(1,3);
(* !(!*LBL G!0!1!2!8!) *)
101: 
(* !(!*LOAD !1 !-!2!) *)
      load(1,2);
(* !(!*JUMPNIL G!0!1!3!0!) *)
      IF R[1] = nilref THEN GOTO 102;
(* !(!*LOAD !2 !-!1!) *)
      load(2,1);
(* !(!*LINK XCONS EXPR !2!) *)
     XXCONS;
(* !(!*LOAD !2 !-!3!) *)
      load(2,3);
(* !(!*LINK CONS EXPR !2!) *)
     XCONS;
(* !(!*STORE !1 !-!3!) *)
      store(1,3);
(* !(!*LBL G!0!1!3!0!) *)
102: 
(* !(!*LOAD !2 !-!3!) *)
      load(2,3);
(* !(!*LOAD !1 !0!) *)
      load10;
(* !(!*LINK SETPLIST EXPR !2!) *)
        IDSPACE[INFO_OF(R[1])].PLIST := R[2];
(* !(!*LOAD !1 !-!2!) *)
      load(1,2);
(* !(!*LBL G!0!1!2!4!) *)
103: 
(* !(!*DEALLOC !4!) *)
      dealloc(4);
(* !(!*EXIT!) *)
end;
(* !(!*ENTRY REMPROP EXPR !2!) *)
(*  EXPR REMPROP *)
procedure PAS231;
begin
(* !(!*ALLOC !0!) *)
(* !(!*LOAD !3 !(QUOTE NIL!)!) *)
      R[3] := nilref;
(* !(!*LINK PUT EXPR !3!) *)
     PAS224;
(* !(!*DEALLOC !0!) *)
(* !(!*EXIT!) *)
end;
procedure PAS232;
forward;
(* !(!*ENTRY LENGTH EXPR !1!) *)
(*  EXPR LENGTH *)
procedure PAS232;
label
      101,
      100;
begin
(* !(!*ALLOC !0!) *)
(* !(!*JUMPC G!0!1!3!5 !1 PAIRTAG!) *)
      IF tag_of(R[1]) = PAIRTAG THEN GOTO 100;
(* !(!*LOAD !1 !(QUOTE !0!)!) *)
      mkint(0,1);
(* !(!*JUMP G!0!1!3!6!) *)
      GOTO 101;
(* !(!*LBL G!0!1!3!5!) *)
100: 
(* !(!*LOAD !1 !(CDR !1!)!) *)
   XCDR;
(* !(!*LINK LENGTH EXPR !1!) *)
     PAS232;
(* !(!*LINK ADD!1 EXPR !1!) *)
     XADD1;
(* !(!*LBL G!0!1!3!6!) *)
101: 
(* !(!*DEALLOC !0!) *)
(* !(!*EXIT!) *)
end;
(* !(!*ENTRY ERRPRT EXPR !1!) *)
(*  EXPR ERRPRT *)
procedure PAS233;
begin
(* !(!*ALLOC !1!) *)
    alloc1;
(* !(!*STORE !1 !0!) *)
      store10;
(* !(!*LOAD !1 !(QUOTE !*!*!*!*! !)!) *)
      mkident(141,1);
(* !(!*LINK PRIN!2 EXPR !1!) *)
     PAS129;
(* !(!*LOAD !1 !0!) *)
      load10;
(* !(!*LINK PRINT EXPR !1!) *)
     XPRINT;
(* !(!*DEALLOC !1!) *)
      dealloc1;
(* !(!*EXIT!) *)
end;
(* !(!*ENTRY MSGPRT EXPR !1!) *)
(*  EXPR MSGPRT *)
procedure PAS234;
begin
(* !(!*ALLOC !1!) *)
    alloc1;
(* !(!*STORE !1 !0!) *)
      store10;
(* !(!*LOAD !1 !(QUOTE !*!*!*! !)!) *)
      mkident(142,1);
(* !(!*LINK PRIN!2 EXPR !1!) *)
     PAS129;
(* !(!*LOAD !1 !0!) *)
      load10;
(* !(!*LINK PRINT EXPR !1!) *)
     XPRINT;
(* !(!*DEALLOC !1!) *)
      dealloc1;
(* !(!*EXIT!) *)
end;
(* !(!*ENTRY FLAGP EXPR !2!) *)
(*  EXPR FLAGP *)
procedure PAS235;
label
      100;
begin
(* !(!*ALLOC !2!) *)
    alloc2;
(* !(!*STORE !1 !0!) *)
      store10;
(* !(!*STORE !2 !-!1!) *)
      store(2,1);
(* !(!*LINK IDP EXPR !1!) *)
     PAS24;
(* !(!*JUMPNIL G!0!1!4!1!) *)
      IF R[1] = nilref THEN GOTO 100;
(* !(!*LOAD !1 !0!) *)
      load10;
(* !(!*LINK PLIST EXPR !1!) *)
        R[1] := IDSPACE[INFO_OF(R[1])].PLIST;
(* !(!*LOAD !2 !1!) *)
      R[2] := R[1];
(* !(!*LOAD !1 !-!1!) *)
      load(1,1);
(* !(!*LINK MEMQ EXPR !2!) *)
     PAS222;
(* !(!*LBL G!0!1!4!1!) *)
100: 
(* !(!*DEALLOC !2!) *)
      dealloc2;
(* !(!*EXIT!) *)
end;
procedure PAS236;
forward;
procedure PAS237;
forward;
(* !(!*ENTRY FLAG EXPR !2!) *)
(*  EXPR FLAG *)
procedure PAS237;
label
      101,
      100;
begin
(* !(!*ALLOC !2!) *)
    alloc2;
(* !(!*STORE !1 !0!) *)
      store10;
(* !(!*STORE !2 !-!1!) *)
      store(2,1);
(* !(!*JUMPC G!0!1!4!5 !1 PAIRTAG!) *)
      IF tag_of(R[1]) = PAIRTAG THEN GOTO 100;
(* !(!*LOAD !1 !(QUOTE NIL!)!) *)
      R[1] := nilref;
(* !(!*JUMP G!0!1!4!6!) *)
      GOTO 101;
(* !(!*LBL G!0!1!4!5!) *)
100: 
(* !(!*LOAD !1 !(CAR !1!)!) *)
   XCAR;
(* !(!*LINK FLAG!1 EXPR !2!) *)
     PAS236;
(* !(!*LOAD !2 !-!1!) *)
      load(2,1);
(* !(!*LOAD !1 !(CDR !0!)!) *)
   ANYcdr(stk[st],R[1]);
(* !(!*LINK FLAG EXPR !2!) *)
     PAS237;
(* !(!*LBL G!0!1!4!6!) *)
101: 
(* !(!*DEALLOC !2!) *)
      dealloc2;
(* !(!*EXIT!) *)
end;
(* !(!*ENTRY FLAG!1 EXPR !2!) *)
(*  EXPR FLAG1 *)
procedure PAS236;
label
      102,
      101,
      100;
begin
(* !(!*ALLOC !2!) *)
    alloc2;
(* !(!*STORE !1 !0!) *)
      store10;
(* !(!*STORE !2 !-!1!) *)
      store(2,1);
(* !(!*JUMPNC G!0!1!5!5 !1 IDTAG!) *)
      IF tag_of(R[1]) <> IDTAG THEN GOTO 100;
(* !(!*LINK PLIST EXPR !1!) *)
        R[1] := IDSPACE[INFO_OF(R[1])].PLIST;
(* !(!*LOAD !2 !1!) *)
      R[2] := R[1];
(* !(!*LOAD !1 !-!1!) *)
      load(1,1);
(* !(!*LINK MEMQ EXPR !2!) *)
     PAS222;
(* !(!*JUMPNIL G!0!1!5!0!) *)
      IF R[1] = nilref THEN GOTO 101;
(* !(!*LBL G!0!1!5!5!) *)
100: 
(* !(!*LOAD !1 !(QUOTE NIL!)!) *)
      R[1] := nilref;
(* !(!*JUMP G!0!1!5!2!) *)
      GOTO 102;
(* !(!*LBL G!0!1!5!0!) *)
101: 
(* !(!*LOAD !1 !0!) *)
      load10;
(* !(!*LINK PLIST EXPR !1!) *)
        R[1] := IDSPACE[INFO_OF(R[1])].PLIST;
(* !(!*LOAD !2 !-!1!) *)
      load(2,1);
(* !(!*LINK XCONS EXPR !2!) *)
     XXCONS;
(* !(!*LOAD !2 !1!) *)
      R[2] := R[1];
(* !(!*LOAD !1 !0!) *)
      load10;
(* !(!*LINK SETPLIST EXPR !2!) *)
        IDSPACE[INFO_OF(R[1])].PLIST := R[2];
(* !(!*LBL G!0!1!5!2!) *)
102: 
(* !(!*DEALLOC !2!) *)
      dealloc2;
(* !(!*EXIT!) *)
end;
procedure PAS238;
forward;
procedure PAS239;
forward;
(* !(!*ENTRY REMFLAG EXPR !2!) *)
(*  EXPR REMFLAG *)
procedure PAS239;
label
      101,
      100;
begin
(* !(!*ALLOC !2!) *)
    alloc2;
(* !(!*STORE !1 !0!) *)
      store10;
(* !(!*STORE !2 !-!1!) *)
      store(2,1);
(* !(!*JUMPC G!0!1!5!8 !1 PAIRTAG!) *)
      IF tag_of(R[1]) = PAIRTAG THEN GOTO 100;
(* !(!*LOAD !1 !(QUOTE NIL!)!) *)
      R[1] := nilref;
(* !(!*JUMP G!0!1!5!9!) *)
      GOTO 101;
(* !(!*LBL G!0!1!5!8!) *)
100: 
(* !(!*LOAD !1 !(CAR !1!)!) *)
   XCAR;
(* !(!*LINK REMFLAG!1 EXPR !2!) *)
     PAS238;
(* !(!*LOAD !2 !-!1!) *)
      load(2,1);
(* !(!*LOAD !1 !(CDR !0!)!) *)
   ANYcdr(stk[st],R[1]);
(* !(!*LINK REMFLAG EXPR !2!) *)
     PAS239;
(* !(!*LBL G!0!1!5!9!) *)
101: 
(* !(!*DEALLOC !2!) *)
      dealloc2;
(* !(!*EXIT!) *)
end;
(* !(!*ENTRY REMFLAG!1 EXPR !2!) *)
(*  EXPR REMFLAG1 *)
procedure PAS238;
label
      101,
      100;
begin
(* !(!*ALLOC !2!) *)
    alloc2;
(* !(!*STORE !1 !0!) *)
      store10;
(* !(!*STORE !2 !-!1!) *)
      store(2,1);
(* !(!*JUMPC G!0!1!6!2 !1 IDTAG!) *)
      IF tag_of(R[1]) = IDTAG THEN GOTO 100;
(* !(!*LOAD !1 !(QUOTE NIL!)!) *)
      R[1] := nilref;
(* !(!*JUMP G!0!1!6!5!) *)
      GOTO 101;
(* !(!*LBL G!0!1!6!2!) *)
100: 
(* !(!*LINK PLIST EXPR !1!) *)
        R[1] := IDSPACE[INFO_OF(R[1])].PLIST;
(* !(!*LOAD !2 !1!) *)
      R[2] := R[1];
(* !(!*LOAD !1 !-!1!) *)
      load(1,1);
(* !(!*LINK MEMQ EXPR !2!) *)
     PAS222;
(* !(!*JUMPNIL G!0!1!6!5!) *)
      IF R[1] = nilref THEN GOTO 101;
(* !(!*LOAD !1 !0!) *)
      load10;
(* !(!*LINK PLIST EXPR !1!) *)
        R[1] := IDSPACE[INFO_OF(R[1])].PLIST;
(* !(!*LOAD !2 !1!) *)
      R[2] := R[1];
(* !(!*LOAD !1 !-!1!) *)
      load(1,1);
(* !(!*LINK DELQ EXPR !2!) *)
     PAS228;
(* !(!*LOAD !2 !1!) *)
      R[2] := R[1];
(* !(!*LOAD !1 !0!) *)
      load10;
(* !(!*LINK SETPLIST EXPR !2!) *)
        IDSPACE[INFO_OF(R[1])].PLIST := R[2];
(* !(!*LBL G!0!1!6!5!) *)
101: 
(* !(!*DEALLOC !2!) *)
      dealloc2;
(* !(!*EXIT!) *)
end;
(* !(!*ENTRY EQ EXPR !2!) *)
(*  EXPR EQ *)
procedure PAS22;
label
      101,
      100;
begin
(* !(!*ALLOC !0!) *)
(* !(!*JUMPN G!0!1!7!0 !2!) *)
      IF R[1] <> R[2] THEN GOTO 100;
(* !(!*LOAD !1 !(QUOTE T!)!) *)
      R[1] := trueref;
(* !(!*JUMP G!0!1!7!1!) *)
      GOTO 101;
(* !(!*LBL G!0!1!7!0!) *)
100: 
(* !(!*LOAD !1 !(QUOTE NIL!)!) *)
      R[1] := nilref;
(* !(!*LBL G!0!1!7!1!) *)
101: 
(* !(!*DEALLOC !0!) *)
(* !(!*EXIT!) *)
end;
(* !(!*ENTRY EQCAR EXPR !2!) *)
(*  EXPR EQCAR *)
procedure PAS240;
label
      101,
      100;
begin
(* !(!*ALLOC !0!) *)
(* !(!*JUMPNC G!0!1!7!4 !1 PAIRTAG!) *)
      IF tag_of(R[1]) <> PAIRTAG THEN GOTO 100;
(* !(!*LOAD !1 !(CAR !1!)!) *)
   XCAR;
(* !(!*JUMPN G!0!1!7!4 !2!) *)
      IF R[1] <> R[2] THEN GOTO 100;
(* !(!*LOAD !1 !(QUOTE T!)!) *)
      R[1] := trueref;
(* !(!*JUMP G!0!1!7!3!) *)
      GOTO 101;
(* !(!*LBL G!0!1!7!4!) *)
100: 
(* !(!*LOAD !1 !(QUOTE NIL!)!) *)
      R[1] := nilref;
(* !(!*LBL G!0!1!7!3!) *)
101: 
(* !(!*DEALLOC !0!) *)
(* !(!*EXIT!) *)
end;
(* !(!*ENTRY NULL EXPR !1!) *)
(*  EXPR NULL *)
procedure PAS25;
begin
(* !(!*ALLOC !0!) *)
(* !(!*LOAD !2 !(QUOTE NIL!)!) *)
      R[2] := nilref;
(* !(!*LINK EQ EXPR !2!) *)
     PAS22;
(* !(!*DEALLOC !0!) *)
(* !(!*EXIT!) *)
end;
(* !(!*ENTRY PLIST EXPR !1!) *)
(*  EXPR PLIST *)
procedure PAS241;
begin
(* !(!*ALLOC !0!) *)
(* !(!*LINK PLIST EXPR !1!) *)
        R[1] := IDSPACE[INFO_OF(R[1])].PLIST;
(* !(!*DEALLOC !0!) *)
(* !(!*EXIT!) *)
end;
(* !(!*ENTRY VALUE EXPR !1!) *)
(*  EXPR VALUE *)
procedure PAS242;
begin
(* !(!*ALLOC !0!) *)
(* !(!*LINK VALUE EXPR !1!) *)
        R[1] := IDSPACE[INFO_OF(R[1])].VAL;
(* !(!*DEALLOC !0!) *)
(* !(!*EXIT!) *)
end;
(* !(!*ENTRY FUNCELL EXPR !1!) *)
(*  EXPR FUNCELL *)
procedure PAS243;
begin
(* !(!*ALLOC !0!) *)
(* !(!*LINK FUNCELL EXPR !1!) *)
        R[1] := IDSPACE[INFO_OF(R[1])].FUNCELL;
(* !(!*DEALLOC !0!) *)
(* !(!*EXIT!) *)
end;
(* !(!*ENTRY SETPLIST EXPR !2!) *)
(*  EXPR SETPLIST *)
procedure PAS244;
begin
(* !(!*ALLOC !0!) *)
(* !(!*LINK SETPLIST EXPR !2!) *)
        IDSPACE[INFO_OF(R[1])].PLIST := R[2];
(* !(!*DEALLOC !0!) *)
(* !(!*EXIT!) *)
end;
(* !(!*ENTRY SETVALUE EXPR !2!) *)
(*  EXPR SETVALUE *)
procedure PAS245;
begin
(* !(!*ALLOC !0!) *)
(* !(!*LINK SETVALUE EXPR !2!) *)
       IDSPACE[INFO_OF(R[1])].VAL := R[2];
(* !(!*DEALLOC !0!) *)
(* !(!*EXIT!) *)
end;
(* !(!*ENTRY SETFUNCELL EXPR !2!) *)
(*  EXPR SETFUNCELL *)
procedure PAS246;
begin
(* !(!*ALLOC !0!) *)
(* !(!*LINK SETFUNCELL EXPR !2!) *)
        IDSPACE[INFO_OF(R[1])].FUNCELL := R[2];
(* !(!*DEALLOC !0!) *)
(* !(!*EXIT!) *)
end;
(* !(!*ENTRY ORDERP EXPR !2!) *)
(*  EXPR ORDERP *)
procedure PAS247;
begin
(* !(!*ALLOC !2!) *)
    alloc2;
(* !(!*STORE !2 !-!1!) *)
      store(2,1);
(* !(!*LINK !*INF EXPR !1!) *)
      mkitem(INTTAG,info_of(R[1]),R[1]);
(* !(!*STORE !1 !0!) *)
      store10;
(* !(!*LOAD !1 !-!1!) *)
      load(1,1);
(* !(!*LINK !*INF EXPR !1!) *)
      mkitem(INTTAG,info_of(R[1]),R[1]);
(* !(!*LOAD !2 !1!) *)
      R[2] := R[1];
(* !(!*LOAD !1 !0!) *)
      load10;
(* !(!*LINK GREATERP EXPR !2!) *)
     XGREATERP;
(* !(!*LINK NULL EXPR !1!) *)
     PAS25;
(* !(!*DEALLOC !2!) *)
      dealloc2;
(* !(!*EXIT!) *)
end;
(* !(!*ENTRY TOKEN EXPR !0!) *)
(*  EXPR TOKEN *)
procedure PAS248;
label
      100;
begin
(* !(!*ALLOC !0!) *)
(* !(!*LINK RDTOK EXPR !0!) *)
     XRDTOK;
(* !(!*STORE !1 !(FLUID TOK!*!)!) *)
      idspace[143].val := R[1];
(* !(!*JUMPNC G!0!1!9!1 !1 CHARTAG!) *)
      IF tag_of(R[1]) <> CHARTAG THEN GOTO 100;
(* !(!*LINK CHAR!2ID EXPR !1!) *)
     SET_TAG(R[1], IDTAG);
(* !(!*STORE !1 !(FLUID TOK!*!)!) *)
      idspace[143].val := R[1];
(* !(!*LBL G!0!1!9!1!) *)
100: 
(* !(!*DEALLOC !0!) *)
(* !(!*EXIT!) *)
end;
(* !(!*ENTRY EQUAL EXPR !2!) *)
(*  EXPR EQUAL *)
procedure PAS226;
label
      103,
      102,
      101,
      100;
begin
(* !(!*ALLOC !2!) *)
    alloc2;
(* !(!*STORE !1 !0!) *)
      store10;
(* !(!*STORE !2 !-!1!) *)
      store(2,1);
(* !(!*JUMPNC G!0!1!9!6 !1 ATOM!) *)
      IF tag_of(R[1]) = PAIRTAG THEN GOTO 100;
(* !(!*JUMPNC G!0!2!0!3 !2 ATOM!) *)
      IF tag_of(R[2]) = PAIRTAG THEN GOTO 101;
(* !(!*LINK EQ EXPR !2!) *)
     PAS22;
(* !(!*JUMP G!0!2!0!1!) *)
      GOTO 103;
(* !(!*LBL G!0!1!9!6!) *)
100: 
(* !(!*JUMPNC G!0!2!0!0 !2 ATOM!) *)
      IF tag_of(R[2]) = PAIRTAG THEN GOTO 102;
(* !(!*LBL G!0!2!0!3!) *)
101: 
(* !(!*LOAD !1 !(QUOTE NIL!)!) *)
      R[1] := nilref;
(* !(!*JUMP G!0!2!0!1!) *)
      GOTO 103;
(* !(!*LBL G!0!2!0!0!) *)
102: 
(* !(!*LOAD !2 !(CAR !2!)!) *)
   ANYcar(R[2],R[2]);
(* !(!*LOAD !1 !(CAR !1!)!) *)
   XCAR;
(* !(!*LINK EQUAL EXPR !2!) *)
     PAS226;
(* !(!*JUMPNIL G!0!2!0!1!) *)
      IF R[1] = nilref THEN GOTO 103;
(* !(!*LOAD !2 !(CDR !-!1!)!) *)
   ANYcdr(stk[st-1],R[2]);
(* !(!*LOAD !1 !(CDR !0!)!) *)
   ANYcdr(stk[st],R[1]);
(* !(!*LINK EQUAL EXPR !2!) *)
     PAS226;
(* !(!*LBL G!0!2!0!1!) *)
103: 
(* !(!*DEALLOC !2!) *)
      dealloc2;
(* !(!*EXIT!) *)
end;
(* !(!*ENTRY ERROR EXPR !2!) *)
(*  EXPR ERROR *)
procedure PAS215;
begin
(* !(!*ALLOC !2!) *)
    alloc2;
(* !(!*STORE !1 !0!) *)
      store10;
(* !(!*STORE !2 !-!1!) *)
      store(2,1);
(* !(!*LOAD !3 !2!) *)
      R[3] := R[2];
(* !(!*LOAD !2 !1!) *)
      R[2] := R[1];
(* !(!*LOAD !1 !(QUOTE !*!*!*!*! ERROR! !)!) *)
      mkident(144,1);
(* !(!*LINK LIST!3 EXPR !3!) *)
     PAS29;
(* !(!*LINK PRINT EXPR !1!) *)
     XPRINT;
(* !(!*LOAD !1 !-!1!) *)
      load(1,1);
(* !(!*STORE !1 !(FLUID EMSG!*!)!) *)
      idspace[145].val := R[1];
(* !(!*LOAD !1 !0!) *)
      load10;
(* !(!*STORE !1 !(FLUID ENUM!*!)!) *)
      idspace[146].val := R[1];
(* !(!*LINK THROW EXPR !1!) *)
     XTHROW;
(* !(!*DEALLOC !2!) *)
      dealloc2;
(* !(!*EXIT!) *)
end;
(* !(!*ENTRY ERRORSET EXPR !3!) *)
(*  EXPR ERRORSET *)
procedure PAS249;
label
      102,
      101,
      100;
begin
(* !(!*ALLOC !2!) *)
    alloc2;
(* !(!*STORE NIL !(FLUID THROWING!*!)!) *)
      idspace[131].val := nilref;
(* !(!*STORE !2 !-!1!) *)
      store(2,1);
(* !(!*LINK CATCH EXPR !1!) *)
     XCATCH;
(* !(!*STORE !1 !0!) *)
      store10;
(* !(!*LOAD !1 !(FLUID THROWING!*!)!) *)
      R[1] := idspace[131].val;
(* !(!*JUMPT G!0!2!0!9!) *)
      IF R[1] <> nilref THEN GOTO 100;
(* !(!*LOAD !1 !0!) *)
      load10;
(* !(!*LINK NCONS EXPR !1!) *)
     XNCONS;
(* !(!*JUMP G!0!2!0!7!) *)
      GOTO 102;
(* !(!*LBL G!0!2!0!9!) *)
100: 
(* !(!*STORE NIL !(FLUID THROWING!*!)!) *)
      idspace[131].val := nilref;
(* !(!*LOAD !1 !-!1!) *)
      load(1,1);
(* !(!*JUMPNIL G!0!2!1!2!) *)
      IF R[1] = nilref THEN GOTO 101;
(* !(!*LOAD !3 !(FLUID EMSG!*!)!) *)
      R[3] := idspace[145].val;
(* !(!*LOAD !2 !(FLUID ENUM!*!)!) *)
      R[2] := idspace[146].val;
(* !(!*LOAD !1 !(QUOTE !*!*!*!*!)!) *)
      mkident(147,1);
(* !(!*LINK LIST!3 EXPR !3!) *)
     PAS29;
(* !(!*LINK PRINT EXPR !1!) *)
     XPRINT;
(* !(!*LBL G!0!2!1!2!) *)
101: 
(* !(!*LOAD !1 !0!) *)
      load10;
(* !(!*LBL G!0!2!0!7!) *)
102: 
(* !(!*DEALLOC !2!) *)
      dealloc2;
(* !(!*EXIT!) *)
end;
procedure PAS250;
forward;
(* !(!*ENTRY FIXP EXPR !1!) *)
(*  EXPR FIXP *)
procedure PAS251;
begin
(* !(!*ALLOC !0!) *)
(* !(!*LINK NUMBERP EXPR !1!) *)
     PAS250;
(* !(!*DEALLOC !0!) *)
(* !(!*EXIT!) *)
end;
procedure PAS252;
forward;
(* !(!*ENTRY ABS EXPR !1!) *)
(*  EXPR ABS *)
procedure PAS253;
label
      101,
      100;
begin
(* !(!*ALLOC !1!) *)
    alloc1;
(* !(!*STORE !1 !0!) *)
      store10;
(* !(!*LINK MINUSP EXPR !1!) *)
     PAS252;
(* !(!*JUMPNIL G!0!2!1!7!) *)
      IF R[1] = nilref THEN GOTO 100;
(* !(!*LOAD !1 !0!) *)
      load10;
(* !(!*LINK MINUS EXPR !1!) *)
     XMINUS;
(* !(!*JUMP G!0!2!1!8!) *)
      GOTO 101;
(* !(!*LBL G!0!2!1!7!) *)
100: 
(* !(!*LOAD !1 !0!) *)
      load10;
(* !(!*LBL G!0!2!1!8!) *)
101: 
(* !(!*DEALLOC !1!) *)
      dealloc1;
(* !(!*EXIT!) *)
end;
(* !(!*ENTRY SUB!1 EXPR !1!) *)
(*  EXPR SUB1 *)
procedure PAS254;
begin
(* !(!*ALLOC !0!) *)
(* !(!*LOAD !2 !(QUOTE !-!1!)!) *)
      mkint(-1,2);
(* !(!*LINK PLUS!2 EXPR !2!) *)
     XPLUS2;
(* !(!*DEALLOC !0!) *)
(* !(!*EXIT!) *)
end;
(* !(!*ENTRY ZEROP EXPR !1!) *)
(*  EXPR ZEROP *)
procedure PAS255;
begin
(* !(!*ALLOC !0!) *)
(* !(!*LOAD !2 !(QUOTE !0!)!) *)
      mkint(0,2);
(* !(!*LINK EQ EXPR !2!) *)
     PAS22;
(* !(!*DEALLOC !0!) *)
(* !(!*EXIT!) *)
end;
(* !(!*ENTRY ONEP EXPR !1!) *)
(*  EXPR ONEP *)
procedure PAS256;
begin
(* !(!*ALLOC !0!) *)
(* !(!*LOAD !2 !(QUOTE !1!)!) *)
      mkint(1,2);
(* !(!*LINK EQ EXPR !2!) *)
     PAS22;
(* !(!*DEALLOC !0!) *)
(* !(!*EXIT!) *)
end;
(* !(!*ENTRY IDP EXPR !1!) *)
(*  EXPR IDP *)
procedure PAS24;
label
      101,
      100;
begin
(* !(!*ALLOC !0!) *)
(* !(!*JUMPNC G!0!2!2!4 !1 IDTAG!) *)
      IF tag_of(R[1]) <> IDTAG THEN GOTO 100;
(* !(!*LOAD !1 !(QUOTE T!)!) *)
      R[1] := trueref;
(* !(!*JUMP G!0!2!2!5!) *)
      GOTO 101;
(* !(!*LBL G!0!2!2!4!) *)
100: 
(* !(!*LOAD !1 !(QUOTE NIL!)!) *)
      R[1] := nilref;
(* !(!*LBL G!0!2!2!5!) *)
101: 
(* !(!*DEALLOC !0!) *)
(* !(!*EXIT!) *)
end;
procedure PAS257;
forward;
(* !(!*ENTRY EXPT EXPR !2!) *)
(*  EXPR EXPT *)
procedure PAS257;
label
      102,
      101,
      100;
begin
(* !(!*ALLOC !2!) *)
    alloc2;
(* !(!*STORE !1 !0!) *)
      store10;
(* !(!*LOAD !1 !2!) *)
      R[1] := R[2];
(* !(!*JUMPN G!0!2!2!8 !(QUOTE !0!)!) *)
      mkitem(INTTAG,0,RXX);
      IF R[1] <> RXX THEN GOTO 100;
(* !(!*LOAD !1 !(QUOTE !1!)!) *)
      mkint(1,1);
(* !(!*JUMP G!0!2!3!0!) *)
      GOTO 102;
(* !(!*LBL G!0!2!2!8!) *)
100: 
(* !(!*STORE !2 !-!1!) *)
      store(2,1);
(* !(!*LINK MINUSP EXPR !1!) *)
     PAS252;
(* !(!*JUMPNIL G!0!2!2!9!) *)
      IF R[1] = nilref THEN GOTO 101;
(* !(!*LOAD !1 !(QUOTE !0!)!) *)
      mkint(0,1);
(* !(!*JUMP G!0!2!3!0!) *)
      GOTO 102;
(* !(!*LBL G!0!2!2!9!) *)
101: 
(* !(!*LOAD !1 !-!1!) *)
      load(1,1);
(* !(!*LINK SUB!1 EXPR !1!) *)
     PAS254;
(* !(!*LOAD !2 !1!) *)
      R[2] := R[1];
(* !(!*LOAD !1 !0!) *)
      load10;
(* !(!*LINK EXPT EXPR !2!) *)
     PAS257;
(* !(!*LOAD !2 !1!) *)
      R[2] := R[1];
(* !(!*LOAD !1 !0!) *)
      load10;
(* !(!*LINK TIMES!2 EXPR !2!) *)
     XTIMES2;
(* !(!*LBL G!0!2!3!0!) *)
102: 
(* !(!*DEALLOC !2!) *)
      dealloc2;
(* !(!*EXIT!) *)
end;
(* !(!*ENTRY FIX EXPR !1!) *)
(*  EXPR FIX *)
procedure PAS258;
begin
(* !(!*ALLOC !0!) *)
(* !(!*DEALLOC !0!) *)
(* !(!*EXIT!) *)
end;
(* !(!*ENTRY FLOAT EXPR !1!) *)
(*  EXPR FLOAT *)
procedure PAS259;
begin
(* !(!*ALLOC !0!) *)
(* !(!*DEALLOC !0!) *)
(* !(!*EXIT!) *)
end;
procedure PAS260;
forward;
(* !(!*ENTRY MAX MACRO !1!) *)
(*  MACRO MAX *)
procedure PAS261;
begin
(* !(!*ALLOC !0!) *)
(* !(!*LOAD !2 !(QUOTE MAX!2!)!) *)
      mkident(148,2);
(* !(!*LOAD !1 !(CDR !1!)!) *)
   XCDR;
(* !(!*LINK EXPAND EXPR !2!) *)
     PAS260;
(* !(!*DEALLOC !0!) *)
(* !(!*EXIT!) *)
end;
(* !(!*ENTRY MIN MACRO !1!) *)
(*  MACRO MIN *)
procedure PAS262;
begin
(* !(!*ALLOC !0!) *)
(* !(!*LOAD !2 !(QUOTE MIN!2!)!) *)
      mkident(149,2);
(* !(!*LOAD !1 !(CDR !1!)!) *)
   XCDR;
(* !(!*LINK EXPAND EXPR !2!) *)
     PAS260;
(* !(!*DEALLOC !0!) *)
(* !(!*EXIT!) *)
end;
(* !(!*ENTRY PLUS MACRO !1!) *)
(*  MACRO PLUS *)
procedure PAS263;
begin
(* !(!*ALLOC !0!) *)
(* !(!*LOAD !2 !(QUOTE PLUS!2!)!) *)
      mkident(150,2);
(* !(!*LOAD !1 !(CDR !1!)!) *)
   XCDR;
(* !(!*LINK EXPAND EXPR !2!) *)
     PAS260;
(* !(!*DEALLOC !0!) *)
(* !(!*EXIT!) *)
end;
(* !(!*ENTRY TIMES MACRO !1!) *)
(*  MACRO TIMES *)
procedure PAS264;
begin
(* !(!*ALLOC !0!) *)
(* !(!*LOAD !2 !(QUOTE TIMES!2!)!) *)
      mkident(151,2);
(* !(!*LOAD !1 !(CDR !1!)!) *)
   XCDR;
(* !(!*LINK EXPAND EXPR !2!) *)
     PAS260;
(* !(!*DEALLOC !0!) *)
(* !(!*EXIT!) *)
end;
(* !(!*ENTRY MAX!2 EXPR !2!) *)
(*  EXPR MAX2 *)
procedure PAS265;
label
      101,
      100;
begin
(* !(!*ALLOC !2!) *)
    alloc2;
(* !(!*STORE !1 !0!) *)
      store10;
(* !(!*STORE !2 !-!1!) *)
      store(2,1);
(* !(!*LINK GREATERP EXPR !2!) *)
     XGREATERP;
(* !(!*JUMPNIL G!0!2!4!1!) *)
      IF R[1] = nilref THEN GOTO 100;
(* !(!*LOAD !1 !0!) *)
      load10;
(* !(!*JUMP G!0!2!4!2!) *)
      GOTO 101;
(* !(!*LBL G!0!2!4!1!) *)
100: 
(* !(!*LOAD !1 !-!1!) *)
      load(1,1);
(* !(!*LBL G!0!2!4!2!) *)
101: 
(* !(!*DEALLOC !2!) *)
      dealloc2;
(* !(!*EXIT!) *)
end;
(* !(!*ENTRY MIN!2 EXPR !2!) *)
(*  EXPR MIN2 *)
procedure PAS266;
label
      101,
      100;
begin
(* !(!*ALLOC !2!) *)
    alloc2;
(* !(!*STORE !1 !0!) *)
      store10;
(* !(!*STORE !2 !-!1!) *)
      store(2,1);
(* !(!*LINK LESSP EXPR !2!) *)
     XLESSP;
(* !(!*JUMPNIL G!0!2!4!5!) *)
      IF R[1] = nilref THEN GOTO 100;
(* !(!*LOAD !1 !0!) *)
      load10;
(* !(!*JUMP G!0!2!4!6!) *)
      GOTO 101;
(* !(!*LBL G!0!2!4!5!) *)
100: 
(* !(!*LOAD !1 !-!1!) *)
      load(1,1);
(* !(!*LBL G!0!2!4!6!) *)
101: 
(* !(!*DEALLOC !2!) *)
      dealloc2;
(* !(!*EXIT!) *)
end;
(* !(!*ENTRY FUNCTION FEXPR !1!) *)
(*  FEXPR FUNCTION *)
procedure PAS267;
begin
(* !(!*ALLOC !0!) *)
(* !(!*LOAD !1 !(CAR !1!)!) *)
   XCAR;
(* !(!*DEALLOC !0!) *)
(* !(!*EXIT!) *)
end;
(* !(!*ENTRY EXPAND EXPR !2!) *)
(*  EXPR EXPAND *)
procedure PAS260;
label
      101,
      100;
begin
(* !(!*ALLOC !2!) *)
    alloc2;
(* !(!*STORE !1 !0!) *)
      store10;
(* !(!*LOAD !1 !(CDR !1!)!) *)
   XCDR;
(* !(!*JUMPT G!0!2!5!0!) *)
      IF R[1] <> nilref THEN GOTO 100;
(* !(!*LOAD !1 !(CAR !0!)!) *)
   ANYcar(stk[st],R[1]);
(* !(!*JUMP G!0!2!5!1!) *)
      GOTO 101;
(* !(!*LBL G!0!2!5!0!) *)
100: 
(* !(!*STORE !2 !-!1!) *)
      store(2,1);
(* !(!*LINK EXPAND EXPR !2!) *)
     PAS260;
(* !(!*LOAD !3 !1!) *)
      R[3] := R[1];
(* !(!*LOAD !2 !(CAR !0!)!) *)
   ANYcar(stk[st],R[2]);
(* !(!*LOAD !1 !-!1!) *)
      load(1,1);
(* !(!*LINK LIST!3 EXPR !3!) *)
     PAS29;
(* !(!*LBL G!0!2!5!1!) *)
101: 
(* !(!*DEALLOC !2!) *)
      dealloc2;
(* !(!*EXIT!) *)
end;
(* !(!*ENTRY NUMBERP EXPR !1!) *)
(*  EXPR NUMBERP *)
procedure PAS250;
label
      101,
      100;
begin
(* !(!*ALLOC !0!) *)
(* !(!*JUMPNC G!0!2!5!5 !1 NUMTAG!) *)
      IF not((tag_of(R[1]) = INTTAG)
       or (tag_of(R[1]) = FIXTAG)) THEN GOTO 100;
(* !(!*LOAD !1 !(QUOTE T!)!) *)
      R[1] := trueref;
(* !(!*JUMP G!0!2!5!6!) *)
      GOTO 101;
(* !(!*LBL G!0!2!5!5!) *)
100: 
(* !(!*LOAD !1 !(QUOTE NIL!)!) *)
      R[1] := nilref;
(* !(!*LBL G!0!2!5!6!) *)
101: 
(* !(!*DEALLOC !0!) *)
(* !(!*EXIT!) *)
end;
(* !(!*ENTRY ATOM EXPR !1!) *)
(*  EXPR ATOM *)
procedure PAS268;
label
      101,
      100;
begin
(* !(!*ALLOC !0!) *)
(* !(!*JUMPNC G!0!2!5!9 !1 ATOM!) *)
      IF tag_of(R[1]) = PAIRTAG THEN GOTO 100;
(* !(!*LOAD !1 !(QUOTE T!)!) *)
      R[1] := trueref;
(* !(!*JUMP G!0!2!6!0!) *)
      GOTO 101;
(* !(!*LBL G!0!2!5!9!) *)
100: 
(* !(!*LOAD !1 !(QUOTE NIL!)!) *)
      R[1] := nilref;
(* !(!*LBL G!0!2!6!0!) *)
101: 
(* !(!*DEALLOC !0!) *)
(* !(!*EXIT!) *)
end;
(* !(!*ENTRY MINUSP EXPR !1!) *)
(*  EXPR MINUSP *)
procedure PAS252;
label
      101,
      100;
begin
(* !(!*ALLOC !0!) *)
(* !(!*JUMPNC G!0!2!6!3 !1 NUMTAG!) *)
      IF not((tag_of(R[1]) = INTTAG)
       or (tag_of(R[1]) = FIXTAG)) THEN GOTO 100;
(* !(!*LOAD !2 !(QUOTE !-!1!)!) *)
      mkint(-1,2);
(* !(!*LINK GREATERP EXPR !2!) *)
     XGREATERP;
(* !(!*JUMPT G!0!2!6!3!) *)
      IF R[1] <> nilref THEN GOTO 100;
(* !(!*LOAD !1 !(QUOTE T!)!) *)
      R[1] := trueref;
(* !(!*JUMP G!0!2!6!5!) *)
      GOTO 101;
(* !(!*LBL G!0!2!6!3!) *)
100: 
(* !(!*LOAD !1 !(QUOTE NIL!)!) *)
      R[1] := nilref;
(* !(!*LBL G!0!2!6!5!) *)
101: 
(* !(!*DEALLOC !0!) *)
(* !(!*EXIT!) *)
end;
(* !(!*ENTRY SET EXPR !2!) *)
(*  EXPR SET *)
procedure PAS269;
label
      102,
      101,
      100;
begin
(* !(!*ALLOC !2!) *)
    alloc2;
(* !(!*STORE !1 !0!) *)
      store10;
(* !(!*STORE !2 !-!1!) *)
      store(2,1);
(* !(!*JUMPNC G!0!2!6!9 !1 IDTAG!) *)
      IF tag_of(R[1]) <> IDTAG THEN GOTO 100;
(* !(!*JUMPE G!0!2!6!9 !(QUOTE T!)!) *)
      IF R[1]=trueref THEN GOTO 100;
(* !(!*JUMPN G!0!2!6!8 !(QUOTE NIL!)!) *)
      IF R[1] <> nilref THEN GOTO 101;
(* !(!*LBL G!0!2!6!9!) *)
100: 
(* !(!*LOAD !1 !2!) *)
      R[1] := R[2];
(* !(!*LINK NCONS EXPR !1!) *)
     XNCONS;
(* !(!*LOAD !2 !0!) *)
      load(2,0);
(* !(!*LINK XCONS EXPR !2!) *)
     XXCONS;
(* !(!*LOAD !2 !(QUOTE SET!)!) *)
      mkident(152,2);
(* !(!*LINK XCONS EXPR !2!) *)
     XXCONS;
(* !(!*JUMP G!0!2!7!2!) *)
      GOTO 102;
(* !(!*LBL G!0!2!6!8!) *)
101: 
(* !(!*LINK SETVALUE EXPR !2!) *)
       IDSPACE[INFO_OF(R[1])].VAL := R[2];
(* !(!*LOAD !1 !-!1!) *)
      load(1,1);
(* !(!*LBL G!0!2!7!2!) *)
102: 
(* !(!*DEALLOC !2!) *)
      dealloc2;
(* !(!*EXIT!) *)
end;
(* !(!*ENTRY PRINC EXPR !1!) *)
(*  EXPR PRINC *)
procedure PAS270;
begin
(* !(!*ALLOC !0!) *)
(* !(!*LINK PRIN!2 EXPR !1!) *)
     PAS129;
(* !(!*DEALLOC !0!) *)
(* !(!*EXIT!) *)
end;
(* !(!*ENTRY PRIN!1 EXPR !1!) *)
(*  EXPR PRIN1 *)
procedure PAS271;
begin
(* !(!*ALLOC !0!) *)
(* !(!*LINK PRIN!2 EXPR !1!) *)
     PAS129;
(* !(!*DEALLOC !0!) *)
(* !(!*EXIT!) *)
end;
(* !(!*ENTRY PRINT EXPR !1!) *)
(*  EXPR PRINT *)
procedure XPRINT;
begin
(* !(!*ALLOC !1!) *)
    alloc1;
(* !(!*STORE !1 !0!) *)
      store10;
(* !(!*LINK PRIN!1 EXPR !1!) *)
     PAS271;
(* !(!*LINK TERPRI EXPR !0!) *)
     XTERPRI;
(* !(!*LOAD !1 !0!) *)
      load10;
(* !(!*DEALLOC !1!) *)
      dealloc1;
(* !(!*EXIT!) *)
end;
(* !(!*ENTRY PRIN!2T EXPR !1!) *)
(*  EXPR PRIN2T *)
procedure PAS272;
begin
(* !(!*ALLOC !1!) *)
    alloc1;
(* !(!*STORE !1 !0!) *)
      store10;
(* !(!*LINK PRIN!2 EXPR !1!) *)
     PAS129;
(* !(!*LINK TERPRI EXPR !0!) *)
     XTERPRI;
(* !(!*LOAD !1 !0!) *)
      load10;
(* !(!*DEALLOC !1!) *)
      dealloc1;
(* !(!*EXIT!) *)
end;
(* !(!*ENTRY LBIND!1 EXPR !2!) *)
(*  EXPR LBIND1 *)
procedure PAS273;
begin
(* !(!*ALLOC !2!) *)
    alloc2;
(* !(!*STORE !1 !0!) *)
      store10;
(* !(!*STORE !2 !-!1!) *)
      store(2,1);
(* !(!*LINK VALUE EXPR !1!) *)
        R[1] := IDSPACE[INFO_OF(R[1])].VAL;
(* !(!*LOAD !2 !0!) *)
      load(2,0);
(* !(!*LINK XCONS EXPR !2!) *)
     XXCONS;
(* !(!*LOAD !2 !(FLUID BSTK!*!)!) *)
      R[2] := idspace[130].val;
(* !(!*LINK CONS EXPR !2!) *)
     XCONS;
(* !(!*STORE !1 !(FLUID BSTK!*!)!) *)
      idspace[130].val := R[1];
(* !(!*LOAD !2 !-!1!) *)
      load(2,1);
(* !(!*LOAD !1 !0!) *)
      load10;
(* !(!*LINK SETVALUE EXPR !2!) *)
       IDSPACE[INFO_OF(R[1])].VAL := R[2];
(* !(!*DEALLOC !2!) *)
      dealloc2;
(* !(!*EXIT!) *)
end;
(* !(!*ENTRY PBIND!1 EXPR !1!) *)
(*  EXPR PBIND1 *)
procedure PAS274;
begin
(* !(!*ALLOC !1!) *)
    alloc1;
(* !(!*STORE !1 !0!) *)
      store10;
(* !(!*LINK VALUE EXPR !1!) *)
        R[1] := IDSPACE[INFO_OF(R[1])].VAL;
(* !(!*LOAD !2 !0!) *)
      load(2,0);
(* !(!*LINK XCONS EXPR !2!) *)
     XXCONS;
(* !(!*LOAD !2 !(FLUID BSTK!*!)!) *)
      R[2] := idspace[130].val;
(* !(!*LINK CONS EXPR !2!) *)
     XCONS;
(* !(!*STORE !1 !(FLUID BSTK!*!)!) *)
      idspace[130].val := R[1];
(* !(!*LOAD !2 !(QUOTE NIL!)!) *)
      R[2] := nilref;
(* !(!*LOAD !1 !0!) *)
      load10;
(* !(!*LINK SETVALUE EXPR !2!) *)
       IDSPACE[INFO_OF(R[1])].VAL := R[2];
(* !(!*DEALLOC !1!) *)
      dealloc1;
(* !(!*EXIT!) *)
end;
(* !(!*ENTRY UNBIND!1 EXPR !0!) *)
(*  EXPR UNBIND1 *)
procedure PAS275;
label
      100;
begin
(* !(!*ALLOC !1!) *)
    alloc1;
(* !(!*LOAD !1 !(FLUID BSTK!*!)!) *)
      R[1] := idspace[130].val;
(* !(!*JUMPC G!0!2!8!9 !1 PAIRTAG!) *)
      IF tag_of(R[1]) = PAIRTAG THEN GOTO 100;
(* !(!*LOAD !2 !(QUOTE BNDUNDERFLOW!)!) *)
      mkident(153,2);
(* !(!*LOAD !1 !(QUOTE !9!9!)!) *)
      mkint(99,1);
(* !(!*LINK ERROR EXPR !2!) *)
     PAS215;
(* !(!*LBL G!0!2!8!9!) *)
100: 
(* !(!*LINK CAAR EXPR !1!) *)
     PAS11;
(* !(!*STORE !1 !0!) *)
      store10;
(* !(!*LOAD !1 !(FLUID BSTK!*!)!) *)
      R[1] := idspace[130].val;
(* !(!*LINK CDAR EXPR !1!) *)
     PAS13;
(* !(!*LOAD !2 !1!) *)
      R[2] := R[1];
(* !(!*LOAD !1 !0!) *)
      load10;
(* !(!*LINK SETVALUE EXPR !2!) *)
       IDSPACE[INFO_OF(R[1])].VAL := R[2];
(* !(!*LOAD !1 !(CDR !(FLUID BSTK!*!)!)!) *)
   ANYcdr(idspace[130].val,R[1]);
(* !(!*STORE !1 !(FLUID BSTK!*!)!) *)
      idspace[130].val := R[1];
(* !(!*DEALLOC !1!) *)
      dealloc1;
(* !(!*EXIT!) *)
end;
(* !(!*ENTRY UNBINDN EXPR !1!) *)
(*  EXPR UNBINDN *)
procedure PAS276;
label
      101,
      100;
begin
(* !(!*ALLOC !1!) *)
    alloc1;
(* !(!*STORE !1 !0!) *)
      store10;
(* !(!*LBL G!0!2!9!3!) *)
100: 
(* !(!*LOAD !2 !(QUOTE !0!)!) *)
      mkint(0,2);
(* !(!*LOAD !1 !0!) *)
      load10;
(* !(!*LINK GREATERP EXPR !2!) *)
     XGREATERP;
(* !(!*JUMPNIL G!0!2!9!2!) *)
      IF R[1] = nilref THEN GOTO 101;
(* !(!*LINK UNBIND!1 EXPR !0!) *)
     PAS275;
(* !(!*LOAD !1 !0!) *)
      load10;
(* !(!*LINK SUB!1 EXPR !1!) *)
     PAS254;
(* !(!*STORE !1 !0!) *)
      store10;
(* !(!*JUMP G!0!2!9!3!) *)
      GOTO 100;
(* !(!*LBL G!0!2!9!2!) *)
101: 
(* !(!*DEALLOC !1!) *)
      dealloc1;
(* !(!*EXIT!) *)
end;
(* !(!*ENTRY UNBINDTO EXPR !2!) *)
(*  EXPR UNBINDTO *)
procedure XUNBINDTO;
label
      101,
      100;
begin
(* !(!*ALLOC !2!) *)
    alloc2;
(* !(!*STORE !1 !0!) *)
      store10;
(* !(!*STORE !2 !-!1!) *)
      store(2,1);
(* !(!*LBL G!0!2!9!9!) *)
100: 
(* !(!*LOAD !1 !(FLUID BSTK!*!)!) *)
      R[1] := idspace[130].val;
(* !(!*JUMPNC G!0!3!0!2 !1 PAIRTAG!) *)
      IF tag_of(R[1]) <> PAIRTAG THEN GOTO 101;
(* !(!*JUMPE G!0!3!0!2 !-!1!) *)
      IF R[1]=stk[st-1] THEN GOTO 101;
(* !(!*LINK UNBIND!1 EXPR !0!) *)
     PAS275;
(* !(!*JUMP G!0!2!9!9!) *)
      GOTO 100;
(* !(!*LBL G!0!3!0!2!) *)
101: 
(* !(!*LOAD !1 !(QUOTE NIL!)!) *)
      R[1] := nilref;
(* !(!*LOAD !1 !0!) *)
      load10;
(* !(!*DEALLOC !2!) *)
      dealloc2;
(* !(!*EXIT!) *)
end;
procedure PAS277;
forward;
procedure PAS278;
forward;
(* !(!*ENTRY EVLAM EXPR !2!) *)
(*  EXPR EVLAM *)
procedure PAS279;
label
      101,
      100;
begin
(* !(!*ALLOC !3!) *)
    alloc3;
(* !(!*STORE !1 !0!) *)
      store10;
(* !(!*JUMPNC G!0!3!0!7 !1 PAIRTAG!) *)
      IF tag_of(R[1]) <> PAIRTAG THEN GOTO 100;
(* !(!*LOAD !1 !(CAR !1!)!) *)
   XCAR;
(* !(!*JUMPE G!0!3!0!6 !(QUOTE LAMBDA!)!) *)
      mkitem(IDTAG,154,RXX);
      IF R[1]=RXX THEN GOTO 101;
(* !(!*LBL G!0!3!0!7!) *)
100: 
(* !(!*LOAD !2 !(QUOTE NOT! DEFINED!)!) *)
      mkident(155,2);
(* !(!*LOAD !1 !(QUOTE !9!9!)!) *)
      mkint(99,1);
(* !(!*LINK ERROR EXPR !2!) *)
     PAS215;
(* !(!*LBL G!0!3!0!6!) *)
101: 
(* !(!*LOAD !1 !(CDR !0!)!) *)
   ANYcdr(stk[st],R[1]);
(* !(!*STORE !1 !0!) *)
      store10;
(* !(!*LOAD !1 !(CAR !1!)!) *)
   XCAR;
(* !(!*STORE !1 !-!2!) *)
      store(1,2);
(* !(!*LINK LBINDN EXPR !2!) *)
     PAS277;
(* !(!*LOAD !1 !(CDR !0!)!) *)
   ANYcdr(stk[st],R[1]);
(* !(!*LINK P!.N EXPR !1!) *)
     PAS278;
(* !(!*STORE !1 !-!1!) *)
      store(1,1);
(* !(!*LOAD !1 !-!2!) *)
      load(1,2);
(* !(!*LINK LENGTH EXPR !1!) *)
     PAS232;
(* !(!*LINK UNBINDN EXPR !1!) *)
     PAS276;
(* !(!*LOAD !1 !-!1!) *)
      load(1,1);
(* !(!*DEALLOC !3!) *)
      dealloc3;
(* !(!*EXIT!) *)
end;
procedure PAS280;
forward;
(* !(!*ENTRY LBINDN EXPR !2!) *)
(*  EXPR LBINDN *)
procedure PAS277;
label
      102,
      101,
      100;
begin
(* !(!*ALLOC !2!) *)
    alloc2;
(* !(!*STORE !1 !0!) *)
      store10;
(* !(!*STORE !2 !-!1!) *)
      store(2,1);
(* !(!*JUMPC G!0!3!1!2 !1 PAIRTAG!) *)
      IF tag_of(R[1]) = PAIRTAG THEN GOTO 100;
(* !(!*LOAD !1 !(QUOTE NIL!)!) *)
      R[1] := nilref;
(* !(!*JUMP G!0!3!1!4!) *)
      GOTO 102;
(* !(!*LBL G!0!3!1!2!) *)
100: 
(* !(!*JUMPC G!0!3!1!3 !2 PAIRTAG!) *)
      IF tag_of(R[2]) = PAIRTAG THEN GOTO 101;
(* !(!*LINK PBINDN EXPR !1!) *)
     PAS280;
(* !(!*JUMP G!0!3!1!4!) *)
      GOTO 102;
(* !(!*LBL G!0!3!1!3!) *)
101: 
(* !(!*LOAD !2 !(CAR !2!)!) *)
   ANYcar(R[2],R[2]);
(* !(!*LOAD !1 !(CAR !1!)!) *)
   XCAR;
(* !(!*LINK LBIND!1 EXPR !2!) *)
     PAS273;
(* !(!*LOAD !2 !(CDR !-!1!)!) *)
   ANYcdr(stk[st-1],R[2]);
(* !(!*LOAD !1 !(CDR !0!)!) *)
   ANYcdr(stk[st],R[1]);
(* !(!*LINK LBINDN EXPR !2!) *)
     PAS277;
(* !(!*LBL G!0!3!1!4!) *)
102: 
(* !(!*DEALLOC !2!) *)
      dealloc2;
(* !(!*EXIT!) *)
end;
(* !(!*ENTRY PBINDN EXPR !1!) *)
(*  EXPR PBINDN *)
procedure PAS280;
label
      101,
      100;
begin
(* !(!*ALLOC !1!) *)
    alloc1;
(* !(!*STORE !1 !0!) *)
      store10;
(* !(!*JUMPC G!0!3!1!7 !1 PAIRTAG!) *)
      IF tag_of(R[1]) = PAIRTAG THEN GOTO 100;
(* !(!*LOAD !1 !(QUOTE NIL!)!) *)
      R[1] := nilref;
(* !(!*JUMP G!0!3!1!8!) *)
      GOTO 101;
(* !(!*LBL G!0!3!1!7!) *)
100: 
(* !(!*LOAD !1 !(CAR !1!)!) *)
   XCAR;
(* !(!*LINK PBIND!1 EXPR !1!) *)
     PAS274;
(* !(!*LOAD !1 !(CDR !0!)!) *)
   ANYcdr(stk[st],R[1]);
(* !(!*LINK PBINDN EXPR !1!) *)
     PAS280;
(* !(!*LBL G!0!3!1!8!) *)
101: 
(* !(!*DEALLOC !1!) *)
      dealloc1;
(* !(!*EXIT!) *)
end;

Added perq-pascal-lisp-project/pas2.red version [9633c0402a].























































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%                                     
% 		PASCAL BASED MINI-LISP
%
% File: 	PAS2.RED - Basic LISP Functions
% ChangeDate: 	10:42pm  Wednesday, 15 July 1981
% By: 		M. L. Griss
%       	Change to add Features for Schlumberger Demo
% 
% 	    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
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

SYMBOLIC PROCEDURE PAIRP X;
  IF PAIRP X THEN T ELSE NIL;

SMACRO PROCEDURE NOTNULL(X);	%For readability.
  X;

SYMBOLIC PROCEDURE NOT X; 
 X EQ NIL;

SYMBOLIC PROCEDURE CODEP X; 
  IF CODEP X THEN T ELSE NIL;

SYMBOLIC PROCEDURE CONSTANTP X; 
   NULL (PAIRP X OR IDP X);

SYMBOLIC PROCEDURE EQN(A,B); 
   A EQ B;

%.  List entries (+ CONS, NCONS, XCONS)

SYMBOLIC PROCEDURE LIST2(R1,R2);
 R1 . NCONS R2;

SYMBOLIC PROCEDURE LIST3(R1,R2,R3);
 R1 .  LIST2(R2,R3);

SYMBOLIC PROCEDURE LIST4(R1,R2,R3,R4);
 R1 .  LIST3(R2,R3,R4);

SYMBOLIC PROCEDURE LIST5(R1,R2,R3,R4,R5);
 R1 .  LIST4(R2,R3,R4,R5);

SYMBOLIC PROCEDURE REVERSE U;
 REV U;

SYMBOLIC PROCEDURE APPEND(U,V);
 BEGIN  U:=REVERSE U;
        WHILE PAIRP U DO <<V :=CAR U . V; U:=CDR U>>;
	RETURN V
 END;

%. procedures to support GET and PUT, FLAG, etc.


SYMBOLIC PROCEDURE MEMBER(A,B); 
   IF NULL B THEN A ELSE IF A EQ CAR B THEN B ELSE A MEMBER CDR B;

SYMBOLIC PROCEDURE PAIR(U,V); 
   IF U AND V THEN (CAR U . CAR V) . PAIR(CDR U,CDR V)
    ELSE IF U OR V THEN ERROR(0,'PAIR)
    ELSE NIL;

SYMBOLIC PROCEDURE SASSOC(U,V,FN); 
   IF NOT PAIRP V THEN APPLY(FN,'(NIL))
    ELSE IF U EQ CAAR V THEN CAR V
    ELSE SASSOC(U,CDR V,FN);

SYMBOLIC PROCEDURE SUBLIS(X,Y); 
   IF NOT PAIRP X THEN Y
    ELSE BEGIN SCALAR U; 
            U := ASSOC(Y,X); 
            RETURN IF U THEN CDR U
                    ELSE IF ATOM Y THEN Y
                    ELSE SUBLIS(X,CAR Y) . SUBLIS(X,CDR Y)
         END;

SYMBOLIC PROCEDURE SUBST(U,V,W); 
   IF NULL V THEN NIL
    ELSE IF V EQ W THEN U
    ELSE IF ATOM W THEN W
    ELSE SUBST(U,V,CAR W) . SUBST(U,V,CDR W);

SYMBOLIC PROCEDURE MEMQ(U,V);
 IF NOT PAIRP V THEN V
  ELSE IF U EQ CAR V THEN V ELSE MEMQ(U,CDR V);

SYMBOLIC PROCEDURE ATSOC(U,V);
 IF NOT PAIRP V THEN V
  ELSE IF (NOT PAIRP CAR V)
	 OR NOT(U EQ CAAR V) THEN ATSOC(U,CDR V)
  ELSE CAR V;

SYMBOLIC PROCEDURE ASSOC(U,V); 
   IF NOT PAIRP V THEN NIL
    ELSE IF ATOM CAR V THEN ERROR(100,LIST(V,'ASSOC))
    ELSE IF U EQ CAAR V THEN CAR V
    ELSE ASSOC(U,CDR V);

SYMBOLIC PROCEDURE DEFLIST(U,IND); 
   IF NOT PAIRP U THEN NIL
    ELSE (<<PUT(CAAR U,IND,CADAR U); CAAR U>>) . DEFLIST(CDR U,IND);

SYMBOLIC PROCEDURE DELETE(U,V); 
   IF NOT PAIRP V THEN NIL 
    ELSE IF U=CAR V THEN CDR V 
    ELSE CAR V . DELETE(U,CDR V);

SYMBOLIC PROCEDURE DELQ(U,V);
   IF NOT PAIRP V THEN V
    ELSE IF U EQ CAR V THEN CDR V
    ELSE CAR V . DELQ(U,CDR V); % Recopy

SYMBOLIC PROCEDURE DELATQ(U,V);
 IF NOT PAIRP V THEN V
  ELSE IF (NOT PAIRP CAR V)
	 OR NOT(U EQ CAAR V) THEN (CAR V . DELATQ(U,CDR V))
  ELSE CDR V;

SYMBOLIC PROCEDURE GET(U,V);
 IF NOT IDP U THEN NIL
 ELSE IF PAIRP (U:=ATSOC(V,PLIST U)) THEN CDR U ELSE NIL;

SYMBOLIC PROCEDURE PUT(U,V,WW);
 BEGIN SCALAR L;
	IF NOT IDP U THEN RETURN WW;
	L:=PLIST U;
	IF ATSOC(V,L) THEN L:=DELATQ(V,L);
	IF NOTNULL WW THEN L:=(V . WW) . L;
	SETPLIST(U,L);
	RETURN WW;
 END;

SYMBOLIC PROCEDURE REMPROP(U,V);
   PUT(U,V,NIL);


SYMBOLIC PROCEDURE LENGTH L;
 IF NOT PAIRP L THEN 0
  ELSE 1+LENGTH CDR L;

SYMBOLIC PROCEDURE ERRPRT L;
 <<PRIN2 '!*!*!*!*! ; PRINT L>>;

SYMBOLIC PROCEDURE MSGPRT L;
 <<PRIN2 '!*!*!*! ; PRINT L>>;

SYMBOLIC PROCEDURE FLAGP(NAM,FLG);
 IDP NAM AND FLG MEMQ PLIST NAM;

SYMBOLIC PROCEDURE FLAG(NAML,FLG);
 IF NOT PAIRP NAML THEN NIL
  ELSE <<FLAG1(CAR NAML,FLG); FLAG(CDR NAML,FLG)>>;

SYMBOLIC PROCEDURE FLAG1(NAM,FLG);
 IF NOT IDP NAM THEN NIL
  ELSE IF FLG MEMQ PLIST NAM THEN NIL
  ELSE SETPLIST(NAM, FLG . PLIST(NAM));

SYMBOLIC PROCEDURE REMFLAG(NAML,FLG);
 IF NOT PAIRP NAML THEN NIL
  ELSE <<REMFLAG1(CAR NAMl,FLG); REMFLAG(CDR NAML,FLG)>>;

SYMBOLIC PROCEDURE REMFLAG1(NAM,FLG);
 IF NOT IDP NAM THEN NIL
  ELSE IF NOT(FLG MEMQ PLIST NAM)THEN NIL
  ELSE SETPLIST(NAM,DELQ(FLG, PLIST(NAM)));

% Interpreter entries for some important OPEN-coded functions;

SYMBOLIC PROCEDURE EQ(U,V);
 IF U EQ V THEN T ELSE NIL; % Careful, only bool-test opencoded

SYMBOLIC PROCEDURE EQCAR(U,V);
 IF  PAIRP  U THEN IF(CAR U EQ V) THEN T ELSE NIL;

SYMBOLIC PROCEDURE NULL U;
 U EQ NIL;

SYMBOLIC PROCEDURE PLIST U;
 PLIST U;

SYMBOLIC PROCEDURE VALUE U;
 VALUE U;

SYMBOLIC PROCEDURE FUNCELL U;
 FUNCELL U;

SYMBOLIC PROCEDURE SETPLIST(U,V);
 SETPLIST(U,V);

SYMBOLIC PROCEDURE SETVALUE(U,V);
 SETVALUE(U,V);

SYMBOLIC PROCEDURE SETFUNCELL(U,V);
 SETFUNCELL(U,V);

%.  Support for ALGebra

SYMBOLIC PROCEDURE ORDERP(X,Y); %.  Compare ID orders
 !*INF(X) <= !*INF(Y);

SYMBOLIC PROCEDURE TOKEN;	%. Renaming
 BEGIN TOK!*:=RDTOK();
       IF CHARP TOK!* THEN TOK!*:=CHAR2ID TOK!*;
       RETURN TOK!*;
 END;

% Can get confused if user changes from non-hashed to hashed cons.

SYMBOLIC PROCEDURE EQUAL(X,Y);
 IF ATOM(X) THEN IF ATOM(Y) THEN X EQ Y ELSE NIL
 ELSE IF ATOM(Y) THEN NIL ELSE EQUAL(CAR X, CAR Y) AND EQUAL(CDR X, CDR Y);

%--------- CATCH/THROW and ERROR handler ---------------

SYMBOLIC PROCEDURE ERROR(X,Y);
 <<PRINT LIST('!*!*!*!*! ERROR! ,X,Y);
   EMSG!* := Y; ENUM!* := X;
   THROW X>>;

SYMBOLIC PROCEDURE ERRORSET(FORM,MSGP,TRACEP);
 BEGIN SCALAR VAL;
   THROWING!* :=NIL;
   VAL:=CATCH FORM;
   IF NOT THROWING!* THEN RETURN LIST VAL;
   THROWING!*:=NIL;
   IF MSGP THEN PRINT LIST('!*!*!*!*,ENUM!*,EMSG!*);
   RETURN VAL
 END;

% More ARITHMETIC
SYMBOLIC PROCEDURE FIXP X; NUMBERP X;

SYMBOLIC PROCEDURE ABS X;
 IF X < 0 THEN (-X) ELSE X;

SYMBOLIC PROCEDURE SUB1 X;
 PLUS2(X,MINUS 1);

SYMBOLIC PROCEDURE ZEROP X;
  X=0;

SYMBOLIC PROCEDURE ONEP X;
  X=1;

SYMBOLIC PROCEDURE IDP X;
 IF IDP X THEN T ELSE NIL;
SYMBOLIC PROCEDURE EXPT(A,B); 
   IF B EQ 0 THEN 1 
    ELSE IF B <0 THEN 0            % Error ?
    ELSE TIMES2(A,A**SUB1 B);

SYMBOLIC PROCEDURE FIX X; X;

SYMBOLIC PROCEDURE FLOAT X; X;
% Should BE MACROS, check problem?

SYMBOLIC MACRO PROCEDURE MAX X; EXPAND(CDR X,'MAX2);

SYMBOLIC MACRO PROCEDURE MIN X; EXPAND(CDR X,'MIN2);

SYMBOLIC MACRO PROCEDURE PLUS X; EXPAND(CDR X,'PLUS2);

SYMBOLIC MACRO PROCEDURE TIMES X;  EXPAND(CDR X,'TIMES2);

SYMBOLIC PROCEDURE MAX2(A,B); IF A>B THEN A ELSE B;

SYMBOLIC PROCEDURE MIN2(A,B); IF A<B THEN A ELSE B;

SYMBOLIC FEXPR PROCEDURE FUNCTION X; CAR X;

SYMBOLIC PROCEDURE EXPAND(L,FN); 
   IF NULL CDR L THEN CAR L ELSE LIST(FN,CAR L,EXPAND(CDR L,FN));

SYMBOLIC PROCEDURE NUMBERP X;
 IF NUMBERP X THEN T ELSE NIL;

SYMBOLIC PROCEDURE ATOM X;
 IF ATOM X THEN T ELSE NIL;

SYMBOLIC PROCEDURE MINUSP X;
 IF NUMBERP X AND X <=(-1) THEN T ELSE NIL;

SYMBOLIC PROCEDURE SET(A,B);
 IF (NOT IDP(A)) OR (A EQ 'T) OR (A EQ 'NIL) THEN
  ('SET .  A . B . NIL) % Error value
  ELSE <<SETVALUE(A,B); B>>;

SYMBOLIC PROCEDURE PRINC X; 
   PRIN2 X;

SYMBOLIC PROCEDURE PRIN1 X;
   PRIN2 X;

SYMBOLIC PROCEDURE PRINT X;
 <<PRIN1 X; TERPRI(); X>>;

SYMBOLIC PROCEDURE PRIN2T X;
  <<PRIN2 X; TERPRI(); X>>;

%. a) Simple Binding for LAMBDA eval
%     Later convert to bstack in PAS0, will need GC hooks

FLUID '(BSTK!*);	% The Binding stack, list of (id . oval)
			% For Special cell model
SYMBOLIC PROCEDURE LBIND1(IDNAME,NVAL); %. For LAMBDA
 <<BSTK!*:=(IDNAME . VALUE(IDNAME)) . BSTK!*;
   SETVALUE(IDNAME,NVAL)>>;

SYMBOLIC PROCEDURE PBIND1(IDNAME);	%. Prog Bind 1 id
 <<BSTK!*:=(IDNAME . VALUE(IDNAME)) . BSTK!*;
   SETVALUE(IDNAME,'NIL)>>;

SYMBOLIC PROCEDURE UNBIND1;		%. Unbind 1 item
  IF PAIRP BSTK!* THEN <<SETVALUE(CAAR BSTK!*,CDAR BSTK!*);
                         BSTK!*:=CDR BSTK!*>>
   ELSE ERROR(99,'BNDUNDERFLOW);

SYMBOLIC PROCEDURE UNBINDN N;		%. Unbind N items
  WHILE N>0 DO <<UNBIND1(); N:=N-1>>;

SYMBOLIC PROCEDURE UNBINDTO(RETVAL,OLDSTK); %. Unbind to CATCH-mark
  <<WHILE PAIRP BSTK!* AND NOT(BSTK!* EQ OLDSTK)
      DO UNBIND1();
    RETVAL>>;

% b) Simple LAMBDA evaluator

SYMBOLIC PROCEDURE EVLAM(LAM,ARGS);	%. Will PAD args NILs
  BEGIN SCALAR VARS,BOD;
	IF NOT (PAIRP LAM AND CAR LAM EQ 'LAMBDA) 
	  THEN RETURN ERROR(99,'Not! defined);
	LAM:=CDR LAM;
	VARS:=CAR LAM; 
	LBINDN(VARS,ARGS);	% Set up BSTK!*
	BOD:=P!.N CDR LAM;	% and do PROGN eval
	UNBINDN LENGTH VARS;	% restore BSTK!*
        RETURN BOD
   END;

SYMBOLIC PROCEDURE LBINDN(VARS,ARGS); %. Bind each element of VARS to ARGS
  IF NOT PAIRP VARS THEN NIL
   ELSE IF NOT PAIRP ARGS THEN PBINDN VARS % rest to NIL
   ELSE <<LBIND1(CAR VARS,CAR ARGS);
          LBINDN(CDR VARS,CDR ARGS)>>;


SYMBOLIC PROCEDURE PBINDN VARS; 	%. Bind each element of VARS to NIL
  IF NOT PAIRP VARS THEN NIL
   ELSE <<PBIND1 CAR VARS;
          PBINDN CDR VARS>>;


END$

Added perq-pascal-lisp-project/pas2.sli version [a63e4bc9d8].

cannot compute difference between binary files

Added perq-pascal-lisp-project/pas2.sym version [fa214de8c2].

cannot compute difference between binary files

Added perq-pascal-lisp-project/pas3.bld version [aa3281dd59].

















































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
DEF s: <SCRATCH>
DEF DSK: DSK:,SYS:
DEF SYS: DSK:,SYS:
pas:PASCMP
OFF SYSLISP$
OFF MSG$
OFF NOUUO$
OFF DOMOVE$             % Can't have BOTH DOMOVE and FXFRM
OFF NOFIXFRM;		% Reduce ALLOCS
ON MACECHO$		%OFF Cuts down size of output file.

% passer fixups

REMPROP('W,'STAT);
REMPROP('PLIST,'STAT);
PUT(QUOTE SETQ,QUOTE UNARY,QUOTE SETQ)$	% Permit FEXPR definitions
PUT(QUOTE AND,QUOTE UNARY,QUOTE AND)$
PUT(QUOTE OR,QUOTE UNARY,QUOTE OR)$

IN PAS2.SYM$
% Perhaps the following lines should really be in POLY.RED, but they
% don't work correctly inside body of text being compiled.
PUT('CAR,'ANYREG,'T)$
PUT('CDR,'ANYREG,'T)$
PUT('VALUE,'OPENCOD,'("        R[1] := idspace[info_of(R[1])].val;"));
PUT('PLIST,'OPENCOD,'("        R[1] := idspace[Info_of(r[1])].plist;"));
PUT('FUNCELL,'OPENCOD,'("        R[1] := idspace[Info_of(r[1])].funcell;"));
PUT('SETVALUE,'OPENCOD,'("       idspace[Info_of(r[1])].val := R[2];"));
PUT('SETPLIST,'OPENCOD,'("        idspace[Info_of(r[1])].plist := R[2];"));
PUT('SETFUNCELL,'OPENCOD,'("        idspace[Info_of(r[1])].funcell := R[2];"));
PUT('CHAR2ID,'OPENCOD,'("     set_tag(R[1], idtag);"));
PUT('CODEP, 'OPENCOD, '("     tag_of(r[1]) = codetag;"));

OUT PAS3.PAS$
DRT1('PAS3,PAS2IDS,PAS2CSTS,PAS2LITS,PAS2FNS)$
IN PAS3.RED$
DRT2()$
SHUT PAS3.PAS$

OUT PAS3.SYM$
DUMPSYMS('PAS3)$
SHUT PAS3.SYM$

OUT PAS3.SLI$
DRT3()$
SHUT PAS3.SLI$

OUT EXEC.PAS$
DMPFLST()$		% Construct EXECUTE table
SHUT EXEC.PAS$

OUT PAS3.INI$
DUMPINI()$
SHUT PAS3.INI$
QUIT$

Added perq-pascal-lisp-project/pas3.ini version [2e35c871bd].

cannot compute difference between binary files

Added perq-pascal-lisp-project/pas3.pas version [24344a2ccf].

cannot compute difference between binary files

Added perq-pascal-lisp-project/pas3.red version [c974fb7893].































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%                                     
% 		PASCAL BASED MINI-LISP
%
% File: 	PAS3.RED - Basic LISP Functions
% ChangeDate: 	10:48pm  Wednesday, 15 July 1981
% By: 		M. L. Griss
%       	Change to add Features for Schlumberger Demo
% 
% 	    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
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

%. Tagged TCATCH and TTHROW In terms of CATCH and THROW

SYMBOLIC PROCEDURE TCATCH(TG,FORM);
 BEGIN SCALAR VAL;
     THROWING!* := NIL;
     VAL:=CATCH(FORM);
     IF NULL TG OR NULL THROWING!* THEN RETURN VAL;	% CatchALL
     IF THROWTAG!* EQ TG THEN RETURN VAL;
     THROW VAL;
 END;

SYMBOLIC PROCEDURE TTHROW(TG,VAL);
 <<THROWING!* := 'T;
   THROWTAG!* := TG;
   THROW VAL>>;

SYMBOLIC PROCEDURE GETD NAM;		%. Return (type.code) if func
  BEGIN SCALAR TY,V;
	IF NOT IDP NAM THEN RETURN NIL;
	TY:=GET(NAM,'TYPE);
	V:=FUNCELL NAM;
	IF NULL TY AND V THEN TY:='EXPR;
        IF V THEN RETURN (TY . V) ELSE RETURN NIL;
  END;

SYMBOLIC PROCEDURE PUTD(NAM,TY,BOD);	%. Make function entry
 IF FLAGP(NAM, 'LOSE) THEN
 <<  ERRPRT LIST(NAM,'not,'flagged,'LOSE); NAM >>
 ELSE BEGIN
	IF GETD(NAM) THEN MSGPRT LIST('Function,NAM,'redefined);
	IF (CODEP BOD OR EQCAR(BOD,'LAMBDA)
          AND TY MEMQ '(EXPR FEXPR NEXPR MACRO) )
 	 THEN <<IF TY EQ 'EXPR THEN TY:=NIL;
                PUT(NAM,'TYPE,TY);
	        SETFUNCELL(NAM,BOD)>>
          ELSE RETURN ERROR(99,LIST(NAM,'Cant,'be,'defined));
	RETURN NAM;
 END;

SYMBOLIC PROCEDURE REMD NAM;		%. Remove function defn
 BEGIN SCALAR PR;
	IF (PR:=GETD NAM) THEN <<SETFUNCELL(NAM,NIL);
				 REMPROP(NAM,'TYPE)>>;
	RETURN PR;
 END;


%. Convenient definitions

SYMBOLIC PROCEDURE PUTL(L,IND,VAL);
 IF NOT PAIRP L THEN NIL
  ELSE <<PUT(CAR L,IND,VAL);
         PUTL(CDR L,IND,VAL)>>;

SYMBOLIC FEXPR PROCEDURE DE L;
   PUTD(CAR L,'EXPR,'LAMBDA . CDR L);

SYMBOLIC FEXPR PROCEDURE DF L;
   PUTD(CAR L,'FEXPR,'LAMBDA . CDR L);

SYMBOLIC FEXPR PROCEDURE DN L;
   PUTD(CAR L,'NEXPR,'LAMBDA . CDR L);

SYMBOLIC FEXPR PROCEDURE DM L;
   PUTD(CAR L,'MACRO,'LAMBDA . CDR L);

%. d) Improved EVAL, with LAMBDA, FEXPR, etc

SYMBOLIC PROCEDURE EVAL(X);
 BEGIN SCALAR FN,A,TY;
 L:IF IDP(X) THEN RETURN VALUE(X)
    ELSE IF NOT PAIRP(X) OR (FN := CAR X) EQ 'LAMBDA THEN
	RETURN X;
    A := CDR X;                         % Arguments
    IF FN EQ 'QUOTE THEN		%Important special Fexprs
	RETURN CAR(A);
    IF FN EQ 'SETQ THEN RETURN SET(CAR A,EVAL CADR A);
    IF IDP FN AND (TY := GET(FN, 'TYPE)) THEN 
     <<IF TY EQ 'FEXPR THEN
           RETURN APPLY1(FN,A);   % No Spread, No EVAL
       IF TY EQ 'NEXPR THEN
        RETURN APPLY1(FN,EVLIS A); % No Spread, EVAL
       IF TY EQ 'MACRO               % Reval full form
          THEN  <<X := APPLY1(FN,X);  GOTO L >> >>;
       A := EVLIS A;
       IF FN EQ 'LIST THEN RETURN A;
       RETURN APPLY(FN,A);
END;

SYMBOLIC PROCEDURE APPLY1(FN,A);
 APPLY(FN, A . NIL);

SYMBOLIC PROCEDURE APPLY(FN,A);
 BEGIN SCALAR EFN;
    EFN := FUNCELL FN;
    IF CODEP EFN THEN RETURN XAPPLY(EFN,A); % Spread args and EXECUTE
    RETURN EVLAM(EFN,A);
END;

SYMBOLIC PROCEDURE EVLIS(L);
IF NOT PAIRP L THEN EVAL L
 ELSE EVAL(CAR L) . EVLIS(CDR L);

%. Some standard FEXPRS and MACROS

SYMBOLIC FEXPR PROCEDURE PROGN ARGS;	%. Evaluate a LIST
  P!.N ARGS;

SYMBOLIC PROCEDURE PROG2(A,B); B;

SYMBOLIC PROCEDURE P!.N ARGS;		%. EVALS elems of list and returns last
BEGIN SCALAR ANS;
   WHILE PAIRP ARGS DO <<ANS := EVAL CAR ARGS; ARGS:=CDR ARGS>>;
  RETURN ANS
END;

%.===== Section 3.7 =====	Program Feature functions

% All this stuff should be rewritten to use the same binding mechanism as
% compiled code, and obey the same constraints on placement of GO/RETURN
% as compiled code.

SYMBOLIC FEXPR PROCEDURE RETURN E;	%. Return From Current PROG
<< P!.P := NIL;
   TTHROW('!$PROG!$,P!.N E) >>;

SYMBOLIC FEXPR PROCEDURE GO E;		%. Go to label in Current PROG
BEGIN SCALAR L;
  E := CAR E;
  REPEAT <<
    WHILE NOT IDP E DO
      ERROR(1100,LIST(E,'Not,'Label));
    L := ATSOC(E,P!.G);
    IF ATOM L THEN
      ERROR(1101,LIST(E,'Not,'a,'label))>>
  UNTIL PAIRP L;
  P!.P := CDR L;
  TTHROW('!$PROG!$,NIL)
END;

SYMBOLIC FEXPR PROCEDURE PROG E;	%. Program feature interpreter
%  P!.P is Next SEXPR to EVAL
BEGIN SCALAR TG,X,V,NVALS,SAVEP,SAVEG;
  SAVEP:=P!.P;
  SAVEG:=P!.G;	% Note FLUIDS not yet working compiled
  NVALS :=LENGTH CAR E;
  PBINDN CAR E;	% Bind each to NIL, putting old value on BSTACK
  P!.P := CDR E; 
% The code body
  X := P!.P;
  P!.G := NIL;
  FOR EACH U ON P!.P DO
    IF IDP CAR U THEN
  P!.G := U . P!.G;
  THROWING!* := NIL;
  TG := '!$PROG!$;
  WHILE P!.P AND TG EQ '!$PROG!$ DO <<
    X := CAR P!.P;
    P!.P := CDR P!.P;
    IF NOT IDP X THEN <<
      X := TCATCH(NIL,X);
      IF THROWING!* THEN
	<<TG := THROWTAG!*; V:=X>>  >> >>;
% UNBIND Even if thrown through
  UNBINDN NVALS;
  P!.P := SAVEP;
  P!.G := SAVEG;
  IF NOT(TG EQ '!$PROG!$) THEN
    TTHROW(TG,V)
  ELSE
    RETURN V
END;


SYMBOLIC FEXPR PROCEDURE WHILE ARGS;	%. Simple WHILE LOOP
% Will do (WHILE bool s1 .. sn)
  BEGIN SCALAR BOOL;
	IF NOT PAIRP ARGS THEN RETURN NIL;
	BOOL:=CAR ARGS;
 L1:	IF NULL EVAL BOOL THEN RETURN NIL;
	P!.N CDR ARGS;
	GOTO L1
 END;


SYMBOLIC FEXPR PROCEDURE AND(X);	%. Xis list of actions
   BEGIN 
     IF NOT PAIRP X THEN RETURN(T);
 L:  IF NULL CDR(X) THEN RETURN(EVAL(CAR X))
      ELSE IF NULL EVAL(CAR X) THEN RETURN(NIL)
      ELSE << X:=CDR X; GOTO L >>
 END;

%/// Add also IF ?

SYMBOLIC FEXPR PROCEDURE COND(E);		%. Conditional eval
   BEGIN SCALAR PR,Y;
 L:  IF NOT PAIRP E THEN RETURN NIL;
     PR:=CAR E; E:=CDR E;
     IF PAIRP PR THEN Y:=CAR PR ELSE Y:=PR;
     IF NULL (Y:=EVAL(Y)) THEN GOTO L;
     IF NULL PAIRP PR OR NULL CDR PR THEN RETURN(Y);
     RETURN P!.N(CDR PR)
   END;

SYMBOLIC FEXPR PROCEDURE  OR(X);	%. Or of action list
   BEGIN SCALAR Y;
 L: IF NOT PAIRP X THEN RETURN(NIL)
     ELSE IF(Y:=EVAL(CAR X)) THEN RETURN(Y)
     ELSE << X:=CDR X;GOTO L >>
 END;

%.===== Section 3.12 =====	MAP composite functions

SYMBOLIC PROCEDURE MAP(X,FN); 		%. Apply FN to each cdr x
   WHILE X DO <<APPLY1(FN,X); X := CDR X>>;

SYMBOLIC PROCEDURE MAPC(X,FN); 		%. Apply FN to each car x
   WHILE X DO <<APPLY1(FN,CAR X); X := CDR X>>;

SYMBOLIC PROCEDURE MAPCAN(X,FN); 	%. Append FN car x
   IF ATOM X THEN NIL ELSE NCONC(APPLY1(FN,CAR X),MAPCAN(CDR X,FN));

SYMBOLIC PROCEDURE MAPCAR(X,FN); 	%. Collect FN car x
   IF ATOM X THEN NIL ELSE APPLY1(FN,CAR X) . MAPCAR(CDR X,FN);

SYMBOLIC PROCEDURE MAPCON(X,FN); 	%. Append FN cdr x
   IF ATOM X THEN NIL ELSE NCONC(APPLY1(FN,X),MAPCON(CDR X,FN));

SYMBOLIC PROCEDURE MAPLIST(X,FN); 	%. Collect FN cdr x
   IF ATOM X THEN NIL ELSE APPLY1(FN,X) . MAPLIST(CDR X,FN);

SYMBOLIC PROCEDURE NCONC(U,V); 		%. Tack V onto end U
   BEGIN SCALAR W; 
      IF ATOM U THEN RETURN V; 
      W := U; 
      WHILE PAIRP CDR W DO W := CDR W; 
      RPLACD(W,V); 
      RETURN U
   END;

%... This procedure drives a simple read/eval/print top loop.

SYMBOLIC PROCEDURE PUTC(X,Y,Z);
  PUT(X,Y,Z);

SYMBOLIC PROCEDURE FLUID L;
  L;

SYMBOLIC PROCEDURE PRIN2TL L;
 IF NOT PAIRP L THEN TERPRI()
  ELSE <<PRIN2 CAR L; PRIN2 '! ; PRIN2TL CDR L>>;
% ... Missing functions to complete Standard LISP set
% ... some dummies developed for PERQ, modified to better use PASLSP


SYMBOLIC PROCEDURE FLOATP X; NIL;

SYMBOLIC PROCEDURE STRINGP X; IDP X;

SYMBOLIC PROCEDURE VECTORP X; NIL;

SYMBOLIC PROCEDURE FLUIDP X; NIL;

SYMBOLIC PROCEDURE INTERN X; X;

SYMBOLIC PROCEDURE REMOB X; NIL;

SYMBOLIC PROCEDURE GLOBAL X; 
   WHILE X DO <<FLAG(X,'GLOBAL); X := CDR X>>;

SYMBOLIC PROCEDURE GLOBALP X; 
   FLAGP(X,'GLOBAL);

SYMBOLIC PROCEDURE UNFLUID X; 
   NIL;


% No vectors yet

SYMBOLIC PROCEDURE GETV(A,B); NIL;

SYMBOLIC PROCEDURE MKVECT X; NIL;

SYMBOLIC PROCEDURE PUTV(A,B,C); NIL;

SYMBOLIC PROCEDURE UPBV X; NIL;

SYMBOLIC PROCEDURE DIGIT X; NIL;

SYMBOLIC PROCEDURE LITER X; NIL;
 
SYMBOLIC PROCEDURE READCH X; NIL;  %/ Needs Interp Mod
 
SYMBOLIC PROCEDURE RDEVPR;
 WHILE T DO PRINT EVAL READ();

SYMBOLIC PROCEDURE DSKIN(FILE);
 BEGIN SCALAR TMP;
   TMP := RDS OPEN(FILE, 'INPUT);
   WHILE NULL EOFP PRINT EVAL READ() DO NIL; %Use RDEVPR ?
   CLOSE RDS TMP;
 END;

SYMBOLIC PROCEDURE !*FIRST!-PROCEDURE;
BEGIN SCALAR X, EOFFLG, OUT;
    PRIN2TL '(Pascal  LISP  V2 !- 15 Feb 1982);
    PRIN2TL '(Copyright (c) 1981 U UTAH);
    PRIN2TL '(All  Rights  Reserved);
    NEXPRS:='(LIST);
    PUTL(NEXPRS,'TYPE,'NEXPR);
    PROCS:='(EXPR FEXPR NEXPR MACRO);
    EOFFLG := NIL;
    % Continue reading Init-File on channel 1;
    WHILE NOT EOFFLG DO
    <<  X := READ();
        EOFFLG := EOFP(X);
	IF NOT EOFFLG THEN
	    EVAL X
    >>;
    RDS(2); % Switch to USER input, THE TTY
    EOFFLG := NIL;
    WHILE NOT EOFFLG DO
      <<OUT := WRS 3; PRIN2 '!>; WRS OUT; % Prompt, OUT holds channel #
        X := READ();
        IF EQCAR(X,'QUIT) THEN EOFFLG := 'T ELSE EOFFLG := EOFP(X);
	IF NOT EOFFLG THEN
	  PRIN2T(CATCH X)
      >>;
    PRIN2T LIST('EXITING,'Top,'Loop);
END;

END;

Added perq-pascal-lisp-project/pas3.sli version [526dcaeccc].

cannot compute difference between binary files

Added perq-pascal-lisp-project/pas3.sym version [ebdc7c9092].

cannot compute difference between binary files

Added perq-pascal-lisp-project/pasasm.pat version [387a720058].





















































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
%Patterns for Lisp to Pascal compilation.  
% Taken from  FORTRAN version
%"system" lisp to Fortran work: "SYSASM.PAT".
%
%Version of 4:23pm  Monday, 13 October 1980.

LISP$ OFF ECHO$ OFF RAISE$

OFF COMP;
ON SYSLISP;

% Very optimized with inline consts, etc.

RULEBLOCK (PAS2,

'(!*ENTRY &1 &2 &3)->
  (BEGIN
	NALLOC:=0;
	W "(*  ",&2," ",&1," *)"$
	W "procedure ",MAPFUN &1,";"$
	DCLRLABELS();		%Declare the labels generated for this routine.
	W "begin";
  RETURN T END),

% Exit VS end of procedure?  Works now since we suppress !*LINKE.
'(!*EXIT)->	
  (BEGIN
	W "end;";
  RETURN T END),

'(!*ALLOC 0)->		T,

'(!*ALLOC 1)->
  (BEGIN
	W "    alloc1;" $
	NALLOC:=1;
  RETURN T END),

'(!*ALLOC 2)->
  (BEGIN
	W "    alloc2;" $
	NALLOC:=2;
  RETURN T END),

'(!*ALLOC 3)->
  (BEGIN
	W "    alloc3;" $
	NALLOC:=3;
  RETURN T END),

'(!*ALLOC &1)->
  (BEGIN
	W "    alloc(",&1,");" $
	NALLOC:=&1;
  RETURN T END),

'(!*DEALLOC 0)->
	<<NALLOC:=0;T>>,

'(!*DEALLOC 1)->
	<<NALLOC:=0;
	  W "      dealloc1;" $
	  T>>,

'(!*DEALLOC 2)->
	<<NALLOC:=0;
	  W "      dealloc2;" $
	T>>,

'(!*DEALLOC 3)->
	<<NALLOC:=0;
	  W "      dealloc3;" $
	T>>,

'(!*DEALLOC &1)->
	<<NALLOC:=0;
	IF &1 NEQ 0 THEN W "      dealloc(",&1,");" $
	T>>,

'(!*LINK &1 &2 &3)->		
  (BEGIN SCALAR X$
	IF X:=GET(&1,'OPENCOD) THEN
	<<% Has OPENCOD form, no retadr needed
	    WLST X$
	    RETURN T$
	>>
	ELSE
	<<
	    W "     ",MAPFUN &1,";";	% simply invoke as proc;
	    RETURN T$
	>>$
 END),

% Suppress LINKE by using ON NOLINKE;
%'(!*LINKE &1 &2 &3 &4)->  NOTHING!

'(!*LOAD 1 0)->
	<<W "      load10;";
	  T>>,

'(!*LOAD &1 &2)->
	(BEGIN SCALAR Y;
	IF &1 NEQ &2 THEN Y:=LOADIT(&1,&2)$   %LOADIT may emit some code.
	IF (REGNAM &1) NEQ Y THEN
	    IF NUMBERP(&1) AND NUMBERP(&2) AND (&2 <= 0) THEN
		W "      load(", &1 , "," , -&2 , ");"
	    ELSE
		W "      ",REGNAM &1," := ",Y,";" $
	RETURN T END),

'(!*MOVE &1 &2) -> % Need to FIX so RXX not used as much.  If no YY then
  (BEGIN SCALAR V1,V2;
	IF &1 EQ &2 THEN RETURN T$
	IF(V1:=EASYSTORE(&1)) THEN
          RETURN <<STOREIT('XX,&2,V1);T>>$
        V2:=LOADIT('XX,&2);
        V1:=LOADIT('YY,&1);
	W "       ",V1," := ",V2,";"$
   RETURN T END),

%**********   Delete--not needed?
%'(!*PUTARR &1 &2 &3) ->
% (BEGIN SCALAR V1,V2;
%	V1:=LOADIT('XX,&2);
%	V2:=LOADIT('YY,&3);
%	W "       ",&1,"(",V1,")=",V2$
%  RETURN T END),
%**********

'(!*STORE 1 0)->
	<<W "      store10;";
	  T>>,

'(!*STORE &1 (FLUID &2))->	PAS2 LIST('!*STORE,&1,LIST('GLOBAL,&2)),

'(!*STORE &1 (GLOBAL &2))->
  (BEGIN SCALAR V;
	IF !*SYSLISP THEN
	    W "      ",WSYSEVAL &2,":=",REGNAM &1,";"
	ELSE
	<<  V :=FNDID &2;
	    W "      idspace[",V,"].val := ",REGNAM &1,";">>$
  RETURN T END),

'(!*STORE NIL &1)->
	<< W "      storenil(", -&1 , ");" ;
	   T>>,

'(!*STORE &1 &2)->
	<<IF NUMBERP(&1) AND NUMBERP(&2) AND (&2 <=0 ) THEN
	    W "      store(", &1 , "," , -&2 , ");"
	  ELSE
	    W "      stk[st",&2,"] := ",REGNAM &1,";"$
	  T>>,

'(!*LBL &1)->	<<W MAPLBL &1,": "$ T>>,

'(!*JUMP &1)->	<<W "      GOTO ",MAPLBL &1,";"$ T>>,

%Delete? --> MAP to CASE?/MLG
'(!*JUMPTABLE &1)->
   <<	W "       JMPIT=R[1]+1"$
	W "       IF((JMPIT.LE.0).OR.(R[1].GE.",LENGTH &1,"))GOTO ",MAPLBL CAR &1;
	WX "      GOTO(",LBLLST CDR &1,")JMPIT"$ T>>,

'(!*JUMPE &1 &2)->
  (BEGIN SCALAR V;
	V:=LOADIT('XX,&2)$
	W "      IF R[1]=",V," THEN GOTO ",MAPLBL &1,";"$
  RETURN T END),

'(!*JUMPN &1 &2)->
  (BEGIN SCALAR V;
	V:=LOADIT('XX,&2)$
	W "      IF R[1] <> ",V," THEN GOTO ",MAPLBL &1,";"$
  RETURN T END),

'(!*JUMPWEQ &1 &2)->
  (BEGIN SCALAR V;
	V:=LOADIT('XX,&2)$
	W "      IF R[1]=",V," THEN GOTO ",MAPLBL &1,";"$
  RETURN T END),

'(!*JUMPWNE &1 &2)->
  (BEGIN SCALAR V;
	V:=LOADIT('XX,&2)$
	W "      IF info_of(R[1]) <> info_of(",V,") THEN GOTO ",MAPLBL &1,";"$
  RETURN T END),

'(!*JUMPWG &1 &2)->
  (BEGIN SCALAR V;
	V:=LOADIT('XX,&2)$
	W "      IF info_of(R[1]) > info_of(",V,") THEN GOTO ",MAPLBL &1,";"
  RETURN T END),

'(!*JUMPWGE &1 &2)->
  (BEGIN SCALAR V;
	V:=LOADIT('XX,&2)$
	W "      IF info_of(R[1]) >= info_of(",V,") THEN GOTO ",MAPLBL &1,";"
  RETURN T END),

'(!*JUMPWL &1 &2)->
  (BEGIN SCALAR V;
	V:=LOADIT('XX,&2)$
	W "      IF info_of(R[1]) < info_of(",V,") THEN GOTO ",MAPLBL &1,";"
  RETURN T END),

'(!*JUMPWLE &1 &2)->
  (BEGIN SCALAR V;
	V:=LOADIT('XX,&2)$
	W "      IF info_of(R[1]) <= info_of(",V,") THEN GOTO ",MAPLBL &1,";" $
  RETURN T END),

'(!*JUMPT &1)->
  <<W "      IF R[1] <> nilref THEN GOTO ",MAPLBL &1,";"; T>>,

'(!*JUMPNIL &1)->
  <<W "      IF R[1] = nilref THEN GOTO ",MAPLBL &1,";"; T>>,

% !*TEST stuff has been replaced by !*JUMPC and !*JUMPNC stuff.
% Form is (!*JUMPC LABL REG TYPE)
'(!*JUMPNC &1 &2 ATOM)->PAS2 LIST('!*JUMPC,&1,&2,'PAIRTAG),

'(!*JUMPC &1 &2 ATOM)->	PAS2 LIST('!*JUMPNC,&1,&2,'PAIRTAG),

'(!*JUMPC &1 &2 NUMTAG)->
  <<W "      IF (tag_of(",REGNAM &2,") = INTTAG)"$
    W "       or (tag_of(",REGNAM &2,") = FIXTAG) THEN GOTO ",MAPLBL &1,";" $
    T>>,

'(!*JUMPNC &1 &2 NUMTAG)->
  <<W "      IF not((tag_of(",REGNAM &2,") = INTTAG)"$
    W "       or (tag_of(",REGNAM &2,") = FIXTAG)) THEN GOTO ",MAPLBL &1,";" $
    T>>,

'(!*JUMPC &1 &2 &3)->
  <<W "      IF tag_of(",REGNAM &2,") = ",&3," THEN GOTO ",MAPLBL &1,";" $
    T>>,

'(!*JUMPNC &1 &2 &3)->
  <<W "      IF tag_of(",REGNAM &2,") <> ",&3," THEN GOTO ",MAPLBL &1,";" $
    T>>,

'(!*FREERSTR &1)->	<<W "      UNBIND(",LENGTH &1,");"$T>>,

'(!*PROGBIND &1)->	
  (BEGIN SCALAR Y$
	FOR EACH X IN &1 DO
	 <<FNDID CAR X$
	W "      PBIND(",-CADR X,!, ,V,");" $T>>$
  RETURN T END),

'(!*LAMBIND &1 &2)->	
  (BEGIN SCALAR X,Y$
	X:=&1$ Y:=&2$
	WHILE X DO
	 <<FNDID CAAR Y$
	   W "      LBIND(",REGNAM CAR X,!,,-CADAR Y,!,,V,");"$
	   X:=CDR X$ Y:=CDR Y>>$
  RETURN T END),

'( &1 &2 BASE &3 WORDS &4 LEFT )-> T,

'(!*CHECK &1 &2 &3) ->
  <<W "       IF tag_of(",REGNAM &1,") <> ",&2,"THEN GOTO ",MAPLBL &3,";"$ T>>,

'(!*CODE &1) -> <<W &1; T>>,

'(!*EVAL &1) -> <<EVAL &1; T>>,

&1->	<<WX "1*** Unknown ",&1," ***** "$T>> )$


PUT('CAAR,'CARCDRFN,'(CAR . CAR))$
PUT('CDAR,'CARCDRFN,'(CDR . CAR))$
PUT('CADR,'CARCDRFN,'(CAR . CDR))$
PUT('CDDR,'CARCDRFN,'(CDR . CDR))$
PUT('CAAAR,'CARCDRFN,'(CAAR . CAR))$
PUT('CADAR,'CARCDRFN,'(CADR . CAR))$
PUT('CAADR,'CARCDRFN,'(CAAR . CDR))$
PUT('CADDR,'CARCDRFN,'(CADR . CDR))$
PUT('CDAAR,'CARCDRFN,'(CDAR . CAR))$
PUT('CDDAR,'CARCDRFN,'(CDDR . CAR))$
PUT('CDADR,'CARCDRFN,'(CDAR . CDR))$
PUT('CDDDR,'CARCDRFN,'(CDDR . CDR))$
PUT('CAAAAR,'CARCDRFN,'(CAAAR . CAR))$
PUT('CAADAR,'CARCDRFN,'(CAADR . CAR))$
PUT('CAAADR,'CARCDRFN,'(CAAAR . CDR))$
PUT('CAADDR,'CARCDRFN,'(CAADR . CDR))$
PUT('CADAAR,'CARCDRFN,'(CADAR . CAR))$
PUT('CADDAR,'CARCDRFN,'(CADDR . CAR))$
PUT('CADADR,'CARCDRFN,'(CADAR . CDR))$
PUT('CADDDR,'CARCDRFN,'(CADDR . CDR))$
PUT('CDAAAR,'CARCDRFN,'(CDAAR . CAR))$
PUT('CDADAR,'CARCDRFN,'(CDADR . CAR))$
PUT('CDAADR,'CARCDRFN,'(CDAAR . CDR))$
PUT('CDADDR,'CARCDRFN,'(CDADR . CDR))$
PUT('CDDAAR,'CARCDRFN,'(CDDAR . CAR))$
PUT('CDDDAR,'CARCDRFN,'(CDDDR . CAR))$
PUT('CDDADR,'CARCDRFN,'(CDDAR . CDR))$
PUT('CDDDDR,'CARCDRFN,'(CDDDR . CDR))$


% Some of the OPEN coded functions;
% Take a LIST of strings, operating on R[1],R[2],...;


PUT('!*INF,'OPENCOD,'("      mkitem(INTTAG,info_of(R[1]),R[1]);"));
PUT('!*TAG,'OPENCOD,'("      mkitem(INTTAG,tag_of(R[1]),R[1]);"));

PUT('!*MKITEM,'OPENCOD,'("      mkitem(tag_of(R[1]),info_of(R[2]),R[1]);"));
PUT('!*INTINF,'OPENCOD,'("      mkitem(INTTAG,info_of(R[1]),R[1]);"));

%Only appropriate for systems lisp.  Solution used here is questionable.
PUT('!*WPLUS2,'OPENCOD,'("       R[1].info:=R[1].info+R[2].info;"));
PUT('!*WDIFFERENCE,'OPENCOD,'("       R[1].info:=R[1].info-R[2].info;"));
PUT('!*WADD1,'OPENCOD,'("       R[1].info:=R[1].info+1;"));
PUT('!*WSUB1,'OPENCOD,'("       R[1].info:=R[1].info-1;"));
PUT('!*WMINUS,'OPENCOD,'("       R[1].info:=-R[1].info;"));
PUT('!*WTIMES2,'OPENCOD,'("       R[1].info:=R[1].info*R[2].info;"));
PUT('!*WQUOTIENT,'OPENCOD,'("       R[1].info:=R[1].info div R[2].info;"));
PUT('!*WREMAINDER,'OPENCOD,'("       R[1].info:=R[1].info mod R[2].info;"));

%NEED support functions for these!
PUT('!*WAND,'OPENCOD,'("       R[1].info:=land(R[1].info, R[2].info);"));
PUT('!*WOR,'OPENCOD, '("       R[1].info:=lor(R[1].info, R[2].info);"));
PUT('!*WXOR,'OPENCOD,'("       R[1].info:=lxor(R[1].info, R[2].info);"));
PUT('!*WNOT,'OPENCOD,'("       R[1].info:=not R[1].info;"));

END$

Added perq-pascal-lisp-project/paslsp-20.bld version [dab79eac6a].











































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
; Command file to assemble PASn pieces together and then compile them.
; for Dec-20 version
;
COP PAS3.INI PASLSP.INI
APP PAS1.SLI PASLSP.INI
APP PAS2.SLI PASLSP.INI
APP PAS3.SLI PASLSP.INI
APP USER.SLI PASLSP.INI
filter d <pas0.pre >s:pl20.pas
append pas1.pas S:PL20.PAS
append pas2.pas S:PL20.PAS
append pas3.pas S:PL20.PAS
append exec.pas S:PL20.PAS
filter d <pasn.pre >s:pl20n.pas
append s:pl20n.pas S:PL20.PAS
pascal
S:PL20.rel
S:PL20.lst
S:PL20.PAS
load S:PL20.REL
save S:PL20.EXE

Added perq-pascal-lisp-project/paslsp-apollo.bld version [5513d23b7a].































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
; Command file to assemble PASn pieces together
; Apollo version
;
COP PAS3.INI PASLSP.INI
APP PAS1.SLI PASLSP.INI
APP PAS2.SLI PASLSP.INI
APP PAS3.SLI PASLSP.INI
APP USER.SLI PASLSP.INI
filter a <pas0.pre >s:plA.pas
append pas1.pas S:PLA.PAS
append pas2.pas S:PLA.PAS
append pas3.pas S:PLA.PAS
append exec.pas S:PLA.PAS
filter a <pasn.pre >s:plAn.pas
append S:plAn.pas S:PLA.PAS

Added perq-pascal-lisp-project/paslsp-ini-read.red version [d62b49912c].

























































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
% File to read PASLSP.INI to produce sorted tables

FLUID '(NID!* IDLIST!* NCONST!* CONSTLIST!* NFN!* FNLIST!*);

lisp procedure IniErr x;
  Error LIST("Bad Ini File ",x);

load gsort;

lisp procedure prinl l;
 for each x in l do print x;

lisp procedure Sorts;
 Begin					
     ReadPaslspInit();
     Prin2t "--------------- Functions ----------------";
     prinl idsort FNLIST!*;
     Prin2t "--------------- Other IDS ----------------";
     prinl idsort IDLIST!*;
     Prin2t "--------------- CONST ----------------";
     prinl CONSTLIST!*;
 End;

lisp procedure ReadPaslspInit;
  BEGIN scalar infil,oldfil;
	% load "symbol table" with identifiers, constants, and functions.  
      infil:=open("paslsp.ini",'input);
      oldfil:=rds(infil);
      NID!*:=RATOM();     % get count of identifiers. 
      IF not fixp NID!* THEN
	    IniErr("*****BAD SYMBOL TABLE, INTEGER EXPECTED AT START");
      IDLIST!*:=NIL;
      FOR i :=  1:NID!* DO
	    IDLIST!* := RATOM() . IDLIST!*;
	% reading token magically loads it into id space. 
	IF not ZeroP RATOM()         % look for zero terminator. 
           then
	    IniErr("*****BAD SYMBOL TABLE, ZERO EXPECTED AFTER IDENTIFIERS");
	NCONST!*:=RATOM();         % count of constants  
	IF not FIXP NCONST!* THEN
          IniErr("*****BAD SYMBOL TABLE, INTEGER EXPECTED BEFORE CONSTANTS");
        CONSTLIST!*:=NIL;
	FOR i := 1:NCONST!* DO
	  CONSTLIST!*:=READ() . CONSTLIST!*;
	IF  not ZeroP RATOM() then
         IniErr("*****BAD SYMBOL TABLE, ZERO EXPECTED AFTER CONSTANTS");

	NFN!*:=RATOM();     % count of functions. 
	IF  not FIXP NFN!* then
	   IniErr("*****BAD SYMBOL TABLE, INTEGER EXPECTED BEFORE FUNCTIONS");
	FNLIST!*:=NIL;
	FOR i := 1:NFN!* DO
	    % for each function 
	    % store associated code 
	    FNLIST!*:=RATOM(). FNLIST!*;
	If not Zerop RATOM() then
         IniErr("*****BAD SYMBOL TABLE, ZERO EXPECTED AFTER FUNCTIONS");
        RDS(oldfil);
	CLOSE infil;
  END;

Added perq-pascal-lisp-project/paslsp-perq.bld version [309a05ecb4].



































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
; Command file to assemble PASn pieces together and then compile them.
def s: <scratch>
def pl: <griss.PASLSP>
; produces PERQ  version.
COP pl:PAS3.INI s:PLPERQ.INI
APP pl:PAS1.SLI s:PLPERQ.INI
APP pl:PAS2.SLI s:PLPERQ.INI
APP pl:PAS3.SLI s:PLPERQ.INI
APP pl:USER.SLI s:PLPERQ.INI
pl:filter p  <pl:pas0.pre >s:PlPerq.pas
pl:filter p  <pl:pasn.pre >s:PlPerqn.pas
append pl:pas1.pas S:PLPERQ.pas
append pl:pas2.pas S:PLPERQ.pas
append pl:pas3.pas S:PLPERQ.pas
append pl:exec.pas S:PLPERQ.pas
append s:PlPerqN.pas S:PLPERQ.pas
; Send S:PlPerq.ini S:PlPerq.pas

Added perq-pascal-lisp-project/paslsp-terak.bld version [9f102df688].































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
; Command file to assemble PASn pieces together and then compile them.
; for Terak-20 version
;
COP PAS3.INI PASLSP.INI
APP PAS1.SLI PASLSP.INI
APP PAS2.SLI PASLSP.INI
APP PAS3.SLI PASLSP.INI
APP USER.SLI PASLSP.INI
filter t <pas0.pre >s:plt.pas
append pas1.pas S:PLT.PAS
append pas2.pas S:PLT.PAS
append pas3.pas S:PLT.PAS
append exec.pas S:PLT.PAS
filter t <pasn.pre >s:pltn.pas
append s:pltn.pas S:PLT.PAS

Added perq-pascal-lisp-project/paslsp-test.photo version [79355f38f7].





















































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890

[PHOTO:  Recording initiated  Mon 15-Feb-82 5:11PM]

LINK FROM CAI.OTTENHEIMER, TTY 102

 TOPS-20 Command processor 4(714)-2
@PLJJS:PL20

PASCAL LISP V2 - 15 NOV 1981 
COPYRIGHT (C) 1981 U UTAH 
ALL RIGHTS RESERVED 
UserInitStart
UserInitEnd
>(*JSETQ *!RAISE T)
NIL
>(SETQ !*RAISE T)
T
>(SETQ !*ECHO T)
T
>(DSKIN "PASLSP>TSTJJJJ.TST")
%%%%%%%%%%%%  Standard - LISP Verification file. %%%%%%%%%%%%%%%%%%%%%%%
%
% Copyright (C) M. Griss and J. Marti, February 1981
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%



% Flags for SYSLISP based PSL


(SETQ !*ECHO T)T

(SETQ FZERO (FLOAT 0))0

(SETQ FONE (FLOAT 1))1


%  The following should return T:
TT
 

(NULL NIL)T
 
(COND (T T))T
 
(COND (NIL NIL) (T T))T
 
%  The following should return NIL:
NILNIL
 
(NULL T)NIL
 
(COND (T NIL))NIL
 
(COND (NIL T) 
      (T NIL))NIL
 
%  The following should be 0
00
 (QUOTE 0)0
 
%  The following minimum set of functions must work:
%   PUTD, PROG, SET, QUOTE, COND, NULL, RETURN, LIST, CAR, CDR,

%   EVAL, PRINT, PRIN1, TERPRI, PROGN, GO.
%  Check PUTD, GETD, LAMBDA 
(PUTD (QUOTE FOO) (QUOTE EXPR) (QUOTE (LAMBDA (X) 3)))FOO

% Expect (EXPR LAMBDA (X) 3)
(GETD (QUOTE FOO))(EXPR LAMBDA (X) 3)

%  Should return 3
(FOO 1)3

(FOO 2)3

%  Test SET :
(SET (QUOTE A) 1)1

A1

(SET (QUOTE B) 2)2

B2

%  Test LIST, CAR, CDR 

%  Expect (1 2 3 4) 1 and (2 3 4) 
(SET (QUOTE A) (LIST 1 2 3 4))(1 2 3 4)

(CAR A)1

(CDR A)(2 3 4)

% Test REDEFINITION in PUTD, PROGN, PRIN1, TERPRI 
(PUTD (QUOTE FOO) (QUOTE EXPR) 
      (QUOTE (LAMBDA (X) (PROGN (PRIN1 X) (TERPRI)))))*** (FUNCTION FOO REDEFINE
D)
FOO

%  expect 1 and 2 printed , value NIL
(FOO 1)1
NIL

(FOO 2)2
NIL

%  Test simple PROG, GO, RETURN 
(PROG NIL (PRINT 1) (PRINT 2))1

2
NIL

(PROG (A) (PRINT A) (PRINT 1))NIL
1
NIL

% Now test GO, RETURN, PROG binding
(SET 'A 'AA)AA
 (SET 'B 'BB)BB

(PROG (A B) (PRINT 'test! binding! of! A!,! B! expect! NIL)
            (PRIN1 A) (PRINT B) 
            (PRINT 'Reset! to! 1!,2)
            (SET 'A 1) (SET 'B 2)
               (PRIN1 A) (PRINT B)
            (PRINT 'test! forward! GO)
               (GO LL)
               (PRINT 'forward! GO! failed)
LL            (PRINT 'Forward! GO! ok)
            (GO L2)
L1        (PRINT '! Should! be! after! BACKWARD! go )

        (PRINT '! now! return! 3)
        (RETURN 3)
L2        (PRINT 'Test! backward! GO)
        (GO L1) )TEST BINDING OF A, B EXPECT NIL
NILNIL
RESET TO 1,2
12
TEST FORWARD GO
FORWARD GO OK
TEST BACKWARD GO
 SHOULD BE AFTER BACKWARD GO
 NOW RETURN 3
3

% Test that A,B correctly rebound, expect AA and BB% 
AAA
 BBB

%  Test simple FEXPR% 
(PUTD (QUOTE FOO) (QUOTE FEXPR) (QUOTE (LAMBDA (X) (PRINT X))))*** (FUNCTION FOO
 REDEFINED)
FOO


% Expect (FEXPR LAMBDA (X) (PRINT X))% 
(GETD (QUOTE FOO))(FEXPR LAMBDA (X) (PRINT X))

%  Expect (1) (1 2) and (1 2 3)% 
(FOO 1)(1)
(1)

(FOO 1 2)(1 2)
(1 2)

(FOO 1 2 3)(1 2 3)
(1 2 3)

%  Finally, TEST EVAL inside an FEXPR % 
(PUTD (QUOTE FOO) (QUOTE FEXPR)
  (QUOTE (LAMBDA (XX) (PRINT (EVAL (CAR XX))))))*** (FUNCTION FOO REDEFINED)
FOO

(FOO 1)1
1


(FOO (NULL NIL))T
T

%  PUTD is being used here to define a function !$TEST.%  
(PUTD (QUOTE !$TEST) (QUOTE FEXPR) (QUOTE 
  (LAMBDA (!$X) 
   (PROG (A B) 
     (SET (QUOTE A) (CDR !$X)) 
LOOP (while A (progn
         %  (print (list 'trying (car a)))
           (SET (QUOTE B) (EVAL (CAR A)))
           (COND ( (null (eq b T)) 
            (PROGN (PRIN1 (LIST '!*!*!*!*!*  (CAR A) '! returned B)) 
                   (TERPRI)))) 
     (SET (QUOTE A) (CDR A)) 
     (GO LOOP)))
     (return (LIST (CAR !$X) '! test! complete)) 
           ))))$TEST
 
% $TEST should be defined.
(GETD (QUOTE !$TEST))(FEXPR LAMBDA ($X) (PROG (A B) (SET (QUOTE A) (CDR $X)) LOO
P (WHILE A (PROGN (SET (QUOTE B) (EVAL (CAR A))) (COND ((NULL (EQ B T)) (PROGN (

PRIN1 (LIST (QUOTE *****) (CAR A) (QUOTE  RETURNED) B)) (TERPRI)))) (SET (QUOTE 
A) (CDR A)) (GO LOOP))) (RETURN (LIST (CAR $X) (QUOTE  TEST COMPLETE)))))
 
%  Global, vector, function-pointer partial test.
(!$TEST 'GLOBAL!,VECTOR (NULL (GLOBAL (QUOTE (!$VECTOR !$CODE TEMP)))) 
     (GLOBALP (QUOTE !$VECTOR)) 
     (GLOBALP (QUOTE !$CODE)) 
     (SET (QUOTE !$VECTOR) (MKVECT 4)) 
     (SET (QUOTE !$CODE) (CDR (GETD (QUOTE CDR)))) )(***** (GLOBALP (QUOTE $VECT
OR))  RETURNED (GLOBAL))
(***** (GLOBALP (QUOTE $CODE))  RETURNED (GLOBAL))
(***** (SET (QUOTE $VECTOR) (MKVECT 4))  RETURNED NIL)
(***** (SET (QUOTE $CODE) (CDR (GETD (QUOTE CDR))))  RETURNED  ##89)
((QUOTE GLOBAL,VECTOR)  TEST COMPLETE)
 
 
 
(!$TEST LIST (EQUAL (LIST 1 (QUOTE A) 'STRING ) 
                    (QUOTE (1 A STRING))))(LIST  TEST COMPLETE)
 

% -----3.1 Elementary Predicates-----%  

% This section tests the elementary predicates of section 3.1 of 
% the Standard LISP Report. In general they will test that the 
% predicate returns non-NIL for the correct case, and NIL for all 
% others.  
 
% CODEP should not return T for numbers as function 
% pointers must not be implemented in this way.  
(!$TEST CODEP (CODEP !$CODE) (NULL (CODEP 1)) 
     (NULL (CODEP T)) (NULL (CODEP NIL)) 
     (NULL (CODEP (QUOTE IDENTIFIER))) 
     (NULL (CODEP 'STRING)) (NULL (CODEP (QUOTE (A . B)))) 
     (NULL (CODEP (QUOTE (A B C)))) 
     (NULL (CODEP !$VECTOR)) )(CODEP  TEST COMPLETE)
 
 
% PAIRP must not return T for vectors even if vectors are 
% implemented as lists.  
(!$TEST PAIRP 
     (PAIRP (QUOTE (A . B))) (PAIRP (QUOTE (NIL))) 
     (PAIRP (QUOTE (A B C))) (NULL (PAIRP 0)) 
     (NULL (PAIRP (QUOTE IDENTIFIER))) 
     (NULL (PAIRP 'STRING)) 

     (NULL (PAIRP !$VECTOR)) )(PAIRP  TEST COMPLETE)
 
 
(!$TEST FIXP (FIXP 1) 
     (NULL (FIXP (QUOTE IDENTIFIER))) 
     (NULL (FIXP (QUOTE 'STRING))) 
     (NULL (FIXP (QUOTE (A . B)))) 
     (NULL (FIXP (QUOTE (A B C)))) 
     (NULL (FIXP !$VECTOR)) 
     (NULL (FIXP !$CODE))  )(FIXP  TEST COMPLETE)
 
 
% T and NIL must test as identifiers as must specially 
% escaped character identifiers.  
(!$TEST IDP (IDP (QUOTE IDENTIFIER)) 
     (IDP NIL)  (IDP T) 
     (IDP (QUOTE !1)) (IDP (QUOTE !A)) (IDP (QUOTE !!)) 
     (IDP (QUOTE !()) (IDP (QUOTE !))) (IDP (QUOTE !.)) 
     (IDP (QUOTE !')) (IDP (QUOTE !*)) (IDP (QUOTE !/)) 
     (IDP (QUOTE !+)) (IDP (QUOTE !-)) (IDP (QUOTE !#)) 
     (IDP (QUOTE ! )) (IDP (QUOTE !1!2!3)) (IDP (QUOTE !*!*!*)) 
     (IDP (QUOTE !'ID)) 

     (NULL (IDP 1)) 
     (NULL (IDP 'STRING)) 
     (NULL (IDP (QUOTE (A . B)))) 
     (NULL (IDP (QUOTE (A B C)))) 
     (NULL (IDP !$VECTOR)) 
     (NULL (IDP !$CODE)) )(***** (NULL (IDP (QUOTE STRING)))  RETURNED NIL)
(***** (NULL (IDP $VECTOR))  RETURNED NIL)
(IDP  TEST COMPLETE)
 
 
% STRINGP should answer T to strings only and not things 
% that might look like strings if the system implements them as 
% identifiers.  
(!$TEST STRINGP (STRINGP 'STRING) 
     (NULL (STRINGP (QUOTE (STRING NOTASTRING)))) 
     (NULL (STRINGP 1)) 
     (NULL (STRINGP (QUOTE A))) 
     (NULL (STRINGP (QUOTE (A . B)))) 
     (NULL (STRINGP (QUOTE (A B C)))) 
     (NULL (STRINGP !$VECTOR)) 
     (NULL (STRINGP !$CODE)) )(***** (NULL (STRINGP (QUOTE A)))  RETURNED NIL)
(***** (NULL (STRINGP $VECTOR))  RETURNED NIL)

(STRINGP  TEST COMPLETE)
 
 
% VECTORP should not answer T to pairs if vectors are 
% implemented as pairs.  
(!$TEST VECTORP (VECTORP !$VECTOR) 
     (NULL (VECTORP 1)) 
     (NULL (VECTORP (QUOTE A))) 
     (NULL (VECTORP 'STRING)) 
     (NULL (VECTORP (QUOTE (A . B)))) 
     (NULL (VECTORP (QUOTE (A B C)))) 
     (NULL (VECTORP !$CODE)) )(***** (VECTORP $VECTOR)  RETURNED NIL)
(VECTORP  TEST COMPLETE)
 
 
% Vectors are constants in Standard LISP. However T and NIL 
% are special global variables with the values T and NIL.  
(!$TEST CONSTANTP (CONSTANTP 1) 
     (CONSTANTP 'STRING) 
     (CONSTANTP !$VECTOR) 
     (CONSTANTP !$CODE) 
     (NULL (CONSTANTP NIL)) 

     (NULL (CONSTANTP T)) 
     (NULL (CONSTANTP (QUOTE A))) 
     (NULL (CONSTANTP (QUOTE (A . B)))) 
     (NULL (CONSTANTP (QUOTE (A B C)))) )(***** (CONSTANTP (QUOTE STRING))  RETU
RNED NIL)
(***** (CONSTANTP $VECTOR)  RETURNED NIL)

***GARBAGE COLLECTOR CALLED
CONSES:        3699
ST    :          58
        3465 PAIRS FREED.
         234 PAIRS IN USE.
MAX GC STACK WAS            5
(CONSTANTP  TEST COMPLETE)
 
 
% An ATOM is anything that is not a pair, thus vectors are 
% atoms.  
(!$TEST ATOM (ATOM T) (ATOM NIL) (ATOM 1) (ATOM 0) 
     (ATOM 'STRING) (ATOM (QUOTE IDENTIFIER)) 
     (ATOM !$VECTOR) 
     (NULL (ATOM (QUOTE (A . B)))) 

     (NULL (ATOM (QUOTE (A B C)))) )(ATOM  TEST COMPLETE)
 
 
 
(!$TEST EQ (EQ NIL NIL) (EQ T T) 
     (EQ !$VECTOR !$VECTOR) 
     (EQ !$CODE !$CODE) 
     (EQ (QUOTE A) (QUOTE A)) 
     (NULL (EQ NIL T)) 
     (NULL (EQ NIL !$VECTOR)) 
     (NULL (EQ (QUOTE (A . B)) (QUOTE (A . B)))) )(***** (NULL (EQ NIL $VECTOR))
  RETURNED NIL)
(EQ  TEST COMPLETE)
 
 
% Function pointers are not numbers, therefore the function 
% pointer $CODE is not EQN to the fixed number 0. Numbers must have 
% the same type to be EQN.  
(!$TEST EQN (EQN 1 1) (EQN 0 0) 
     (EQN FONE FONE)  (EQN FZERO FZERO) 
     (NULL (EQN FONE FZERO)) (NULL (EQN FZERO FONE)) 
     (NULL (EQN 1 FONE)) (NULL (EQN 0 FZERO)) 

     (NULL (EQN 1 0)) (NULL (EQN 0 1)) 
     (NULL (EQN 0 !$CODE)) 
     (NULL (EQN NIL 0)) 
     (EQN NIL NIL)  (EQN T T) (EQN !$VECTOR !$VECTOR) 
     (EQN !$CODE !$CODE) (EQN (QUOTE A) (QUOTE A)) 
     (NULL (EQN (QUOTE (A . B)) (QUOTE (A . B)))) 
     (NULL (EQN (QUOTE (A B C)) (QUOTE (A B C))))  )(***** (NULL (EQN 1 FONE))  
RETURNED NIL)
(***** (NULL (EQN 0 FZERO))  RETURNED NIL)
(EQN  TEST COMPLETE)
 
 
% EQUAL checks for general equality rather than specific, so 
% it must check all elements of general expressions and all elements 
% of vectors for equality. This test assumes that CAR does not have 
% the function pointer value  EQUAL to 0. Further tests of EQUAL 
% are in the vector section 3.9.  
(!$TEST EQUAL (EQUAL NIL NIL) 
     (EQUAL T T) 
     (NULL (EQUAL NIL T)) 
     (EQUAL !$CODE !$CODE) 
     (NULL (EQUAL !$CODE (CDR (GETD (QUOTE CAR))))) 

     (EQUAL (QUOTE IDENTIFIER) (QUOTE IDENTIFIER)) 
     (NULL (EQUAL (QUOTE IDENTIFIER1) (QUOTE IDENTIFIER2))) 
     (EQUAL 'STRING 'STRING) 
     (NULL (EQUAL 'STRING1 'STRING2)) 
     (EQUAL 0 0) 
     (NULL (EQUAL 0 1)) 
     (EQUAL (QUOTE (A . B)) (QUOTE (A . B))) 
     (NULL (EQUAL (QUOTE (A . B)) (QUOTE (A . C)))) 
     (NULL (EQUAL (QUOTE (A . B)) (QUOTE (C . B)))) 
     (EQUAL (QUOTE (A B)) (QUOTE (A B))) 
     (NULL (EQUAL (QUOTE (A B)) (QUOTE (A C)))) 
     (NULL (EQUAL (QUOTE (A B)) (QUOTE (C B)))) 
     (EQUAL !$VECTOR !$VECTOR) 
     (NULL (EQUAL 0 NIL)) 
     (NULL (EQUAL 'T T)) 
     (NULL (EQUAL 'NIL NIL)) )(***** (NULL (EQUAL (QUOTE T) T))  RETURNED NIL)
(***** (NULL (EQUAL (QUOTE NIL) NIL))  RETURNED NIL)
(EQUAL  TEST COMPLETE)
 
 
% -----3.2 Functions on Dotted-Pairs-----%  
% Test the C....R functions by simply verifying that they select

% correct part of a structure.
(!$TEST CAR (EQ (CAR (QUOTE (A . B))) (QUOTE A)) 
    (EQUAL (CAR (QUOTE ((A) . B))) (QUOTE (A))) )(CAR  TEST COMPLETE)
 
 
(!$TEST CDR (EQ (CDR (QUOTE (A . B))) (QUOTE B)) 
     (EQUAL (CDR (QUOTE (A B))) (QUOTE (B))) )(CDR  TEST COMPLETE)
 
 
(!$TEST CAAR (EQ (CAAR (QUOTE ((A)))) (QUOTE A)))(CAAR  TEST COMPLETE)
 
(!$TEST CADR (EQ (CADR (QUOTE (A B))) (QUOTE B)))(CADR  TEST COMPLETE)
 
(!$TEST CDAR (EQ (CDAR (QUOTE ((A . B)))) (QUOTE B)))(CDAR  TEST COMPLETE)
 
(!$TEST CDDR (EQ (CDDR (QUOTE (A . (B . C)))) (QUOTE C)))(CDDR  TEST COMPLETE)
 
 
(!$TEST CAAAR (EQ (CAAAR (QUOTE (((A))))) (QUOTE A)))(CAAAR  TEST COMPLETE)
 
(!$TEST CAADR (EQ (CAADR (QUOTE (A (B)))) (QUOTE B)))(CAADR  TEST COMPLETE)
 

(!$TEST CADAR (EQ (CADAR (QUOTE ((A B)))) (QUOTE B)))(CADAR  TEST COMPLETE)
 
(!$TEST CADDR (EQ (CADDR (QUOTE (A B C))) (QUOTE C)))(CADDR  TEST COMPLETE)
 
(!$TEST CDAAR (EQ (CDAAR (QUOTE (((A . B)) C))) (QUOTE B)))(CDAAR  TEST COMPLETE
)
 
(!$TEST CDADR (EQ (CDADR (QUOTE (A (B . C)))) (QUOTE C)))(CDADR  TEST COMPLETE)
 
(!$TEST CDDAR (EQ (CDDAR (QUOTE ((A . (B . C))))) (QUOTE C)))(CDDAR  TEST COMPLE
TE)
 
(!$TEST CDDDR (EQ (CDDDR (QUOTE (A . (B . (C . D))))) (QUOTE D)))(CDDDR  TEST CO
MPLETE)
 
 
(!$TEST CAAAAR (EQ (CAAAAR (QUOTE ((((A)))))) (QUOTE A)))(CAAAAR  TEST COMPLETE)
 
(!$TEST CAAADR (EQ (CAAADR (QUOTE (A ((B))))) (QUOTE B)))(CAAADR  TEST COMPLETE)
 
(!$TEST CAADAR (EQ (CAADAR (QUOTE ((A (B))))) (QUOTE B)))(CAADAR  TEST COMPLETE)
 

(!$TEST CAADDR (EQ (CAADDR (QUOTE (A . (B (C))))) (QUOTE C)))(CAADDR  TEST COMPL
ETE)
 
(!$TEST CADAAR (EQ (CADAAR (QUOTE (((A . (B)))))) (QUOTE B)))(CADAAR  TEST COMPL
ETE)
 
(!$TEST CADADR (EQ (CADADR (QUOTE (A (B . (C))))) (QUOTE C)))(CADADR  TEST COMPL
ETE)
 
(!$TEST CADDAR (EQ (CADDAR (QUOTE ((A . (B . (C)))))) (QUOTE C)))
***GARBAGE COLLECTOR CALLED
CONSES:        3465
ST    :          84
        3500 PAIRS FREED.
         199 PAIRS IN USE.
MAX GC STACK WAS            5
(CADDAR  TEST COMPLETE)
 
(!$TEST CADDDR (EQ (CADDDR (QUOTE (A . (B . (C . (D)))))) (QUOTE D)))(CADDDR  TE
ST COMPLETE)
 
(!$TEST CDAAAR (EQ (CDAAAR (QUOTE ((((A . B)))))) (QUOTE B)))(CDAAAR  TEST COMPL

ETE)
 
(!$TEST CDAADR (EQ (CDAADR (QUOTE (A ((B . C))))) (QUOTE C)))(CDAADR  TEST COMPL
ETE)
 
(!$TEST CDADAR (EQ (CDADAR (QUOTE ((A (B . C))))) (QUOTE C)))(CDADAR  TEST COMPL
ETE)
 
(!$TEST CDADDR (EQ (CDADDR (QUOTE (A . (B . ((C . D)))))) (QUOTE D)))(CDADDR  TE
ST COMPLETE)
 
(!$TEST CDDAAR (EQ (CDDAAR (QUOTE (((A . (B . C)))))) (QUOTE C)))(CDDAAR  TEST C
OMPLETE)
 
(!$TEST CDDADR (EQ (CDDADR (QUOTE (A . ((B . (C . D)))))) (QUOTE D)))(CDDADR  TE
ST COMPLETE)
 
(!$TEST CDDDAR (EQ (CDDDAR (QUOTE ((A  . (B . (C . D)))))) (QUOTE D)))(CDDDAR  T
EST COMPLETE)
 
(!$TEST CDDDDR (EQ (CDDDDR (QUOTE (A . (B . (C . (D . E)))))) (QUOTE E)))(CDDDDR
  TEST COMPLETE)

 
 
% CONS should return a unique cell when invoked. Also test that
% the left and right parts are set correctly.
(!$TEST CONS (NULL (EQ (CONS (QUOTE A) (QUOTE B)) (QUOTE (A . B)))) 
     (EQ (CAR (CONS (QUOTE A) (QUOTE B))) (QUOTE A)) 
     (EQ (CDR (CONS (QUOTE A) (QUOTE B))) (QUOTE B)) )(CONS  TEST COMPLETE)
 
 
% Veryify that RPLACA doesn't modify the binding of a list, and
% that only the CAR part of the cell is affected.
(!$TEST RPLACA 
  (SET (QUOTE TEMP) (QUOTE (A))) 
  (EQ (RPLACA TEMP 1) TEMP) 
  (EQ (CAR (RPLACA TEMP (QUOTE B))) (QUOTE B))  
  (EQ (CDR TEMP) NIL) )(***** (SET (QUOTE TEMP) (QUOTE (A)))  RETURNED (A))
(RPLACA  TEST COMPLETE)

 
(!$TEST RPLACD 
  (SET (QUOTE TEMP) (QUOTE (A . B))) 
  (EQ (RPLACD TEMP (QUOTE A)) TEMP) 

  (EQ (CDR (RPLACD TEMP (QUOTE C))) (QUOTE C))  
  (EQ (CAR TEMP) (QUOTE A)) )(***** (SET (QUOTE TEMP) (QUOTE (A . B)))  RETURNED
 (A . B))
(RPLACD  TEST COMPLETE)

 
% -----3.3 Identifiers-----%  
% Verify that COMPRESS handles the various types of lexemes
% correctly.
(!$TEST COMPRESS 
  (NULL (EQ (COMPRESS (QUOTE (A B))) (COMPRESS (QUOTE (A B))))) 
  (EQN (COMPRESS (QUOTE (!1 !2))) 12) 
  (EQN (COMPRESS (QUOTE (!+ !1 !2))) 12) 
  (EQN (COMPRESS (QUOTE (!- !1 !2))) -12) 
  (EQUAL (COMPRESS (QUOTE ( S T R I N G ))) 'STRING) 
  (EQ (INTERN (COMPRESS (QUOTE (A B)))) (QUOTE AB))   
  (EQ (INTERN (COMPRESS (QUOTE (!! !$ A)))) (QUOTE !$A)) )(***** (NULL (EQ (COMP
RESS (QUOTE (A B))) (COMPRESS (QUOTE (A B)))))  RETURNED NIL)
(***** (EQ (INTERN (COMPRESS (QUOTE (! $ A)))) (QUOTE $A))  RETURNED NIL)
(COMPRESS  TEST COMPLETE)

 

% Verify that EXPLODE returns the expected lists and that COMPRESS
% and explode are inverses of each other.
(!$TEST EXPLODE 
  (EQUAL (EXPLODE 12) (QUOTE (!1 !2))) 
  (EQUAL (EXPLODE -12) (QUOTE (!- !1 !2))) 
  (EQUAL (EXPLODE 'STRING) (QUOTE ( S T R I N G ))) 
  (EQUAL (EXPLODE (QUOTE AB)) (QUOTE (A B)) ) 
  (EQUAL (EXPLODE (QUOTE !$AB)) (QUOTE (!! !$ A B)))   
  (EQUAL (COMPRESS (EXPLODE 12)) 12)
  (EQUAL (COMPRESS (EXPLODE -12)) -12)
  (EQUAL (COMPRESS (EXPLODE 'STRING)) 'STRING)
  (EQ (INTERN (COMPRESS (EXPLODE (QUOTE AB)))) (QUOTE AB))
  (EQ (INTERN (COMPRESS (EXPLODE (QUOTE !$AB)))) (QUOTE !$AB)) )(***** (EQUAL (E
XPLODE (QUOTE $AB)) (QUOTE (! $ A B)))  RETURNED NIL)
(EXPLODE  TEST COMPLETE)

 
% Test that GENSYM returns identifiers and that they are different.
(!$TEST GENSYM 
  (IDP (GENSYM)) 
  (NULL (EQ (GENSYM) (GENSYM))) )(GENSYM  TEST COMPLETE)
 

 
% Test that INTERN works on strings to produce identifiers the same
% as those read in. Try ID's with special characters in them (more
% will be tested with READ).
(!$TEST INTERN 
  (EQ (INTERN 'A) (QUOTE A)) 
  (EQ (INTERN 'A12) (QUOTE A12))
  (EQ (INTERN 'A!*) (QUOTE A!*))
  (NULL (EQ (INTERN 'A) (INTERN 'B))) )(INTERN  TEST COMPLETE)
 
 
% Just test that REMOB returns the ID removed.
(!$TEST REMOB 
  (EQ (REMOB (QUOTE AAAA)) (QUOTE AAAA)) )(***** (EQ (REMOB (QUOTE AAAA)) (QUOTE
 AAAA))  RETURNED NIL)
(REMOB  TEST COMPLETE)
 
 
% ----- 3.4 Property List Functions-----%  
% Test that FLAG always returns NIL. More testing is done in FLAGP.
(!$TEST FLAG 
  (NULL (FLAG NIL (QUOTE W))) 

  (NULL (FLAG (QUOTE (U V T NIL)) (QUOTE X))) 
  (NULL (FLAG (QUOTE (U)) NIL)) )(FLAG  TEST COMPLETE)
 
 
% Test that FLAG worked only on a list. Test all items in a flagged
% list were flagged and that those that weren't aren't.
(!$TEST FLAGP 
  (NULL (FLAGP NIL (QUOTE W))) 
  (FLAGP (QUOTE U) (QUOTE X)) 
  (FLAGP (QUOTE V) (QUOTE X)) 
  (FLAGP T (QUOTE X)) 
  (FLAGP NIL (QUOTE X)) 
  (FLAGP (QUOTE U) NIL) )(***** (FLAGP (QUOTE U) (QUOTE X))  RETURNED (X))
(***** (FLAGP (QUOTE V) (QUOTE X))  RETURNED (X))
(***** (FLAGP T (QUOTE X))  RETURNED (X))
(***** (FLAGP NIL (QUOTE X))  RETURNED (X))
(***** (FLAGP (QUOTE U) NIL)  RETURNED (NIL X))
(FLAGP  TEST COMPLETE)
 
 
% Test that REMFLAG always returns NIL and that flags removed are
% gone. Test that unremoved flags are still present.

(!$TEST REMFLAG 
  (NULL (REMFLAG NIL (QUOTE X))) 
  (NULL (REMFLAG (QUOTE (U T NIL)) (QUOTE X))) 
  (NULL (FLAGP (QUOTE U) (QUOTE X))) 
  (FLAGP (QUOTE V) (QUOTE X)) 
  (NULL (FLAGP T (QUOTE X))) 
  (NULL (FLAGP NIL (QUOTE X))) )(***** (FLAGP (QUOTE V) (QUOTE X))  RETURNED (X)
)
(REMFLAG  TEST COMPLETE)
 
 
(!$TEST PUT 
  (EQ (PUT (QUOTE U) (QUOTE IND1) (QUOTE PROP)) (QUOTE PROP)) 
  (EQN (PUT (QUOTE U) (QUOTE IND2) 0) 0) 
  (EQ (PUT (QUOTE U) (QUOTE IND3) !$VECTOR) !$VECTOR) 
  (EQ (PUT (QUOTE U) (QUOTE IND4) !$CODE) !$CODE) )(PUT  TEST COMPLETE)
 
 
(!$TEST GET 
  (EQ (GET (QUOTE U) (QUOTE IND1)) (QUOTE PROP)) 
  (EQN (GET (QUOTE U) (QUOTE IND2)) 0) 
  (EQ (GET (QUOTE U) (QUOTE IND3)) !$VECTOR) 

  (EQ (GET (QUOTE U) (QUOTE IND4)) !$CODE) )
***GARBAGE COLLECTOR CALLED
CONSES:        3500
ST    :          68
        3460 PAIRS FREED.
         239 PAIRS IN USE.
MAX GC STACK WAS            5
(GET  TEST COMPLETE)
 
 
(!$TEST REMPROP 
  (NULL (REMPROP !$CODE !$CODE)) 
  (EQ (REMPROP (QUOTE U) (QUOTE IND1)) (QUOTE PROP)) 
  (NULL (GET (QUOTE U) (QUOTE IND1))) 
  (EQN (REMPROP (QUOTE U) (QUOTE IND2)) (QUOTE 0)) 
  (NULL (GET (QUOTE U) (QUOTE IND2))) 
  (EQ (REMPROP (QUOTE U) (QUOTE IND3)) !$VECTOR) 
  (NULL (GET (QUOTE U) (QUOTE IND3))) 
  (GET (QUOTE U) (QUOTE IND4)) 
  (EQ (REMPROP (QUOTE U) (QUOTE IND4)) !$CODE) 
  (NULL (GET (QUOTE U) (QUOTE IND4)))  )(***** (EQ (REMPROP (QUOTE U) (QUOTE IND
1)) (QUOTE PROP))  RETURNED NIL)

(***** (EQN (REMPROP (QUOTE U) (QUOTE IND2)) (QUOTE 0))  RETURNED NIL)
(***** (GET (QUOTE U) (QUOTE IND4))  RETURNED  ##89)
(***** (EQ (REMPROP (QUOTE U) (QUOTE IND4)) $CODE)  RETURNED NIL)
(REMPROP  TEST COMPLETE)
 
 
 
% -----3.5 Function Definition-----% 
(!$TEST DE 
        (EQ (DE FIE (X) (PLUS2 X 1)) (QUOTE FIE))
        (GETD (QUOTE FIE))
        (EQN (FIE 1) 2)
)(***** (GETD (QUOTE FIE))  RETURNED (EXPR LAMBDA (X) (PLUS2 X 1)))
(DE  TEST COMPLETE)

% Expect (FIE 1) to return 2% 
(FIE 1)2

% Expect FIE redefined in DF test% 
(!$TEST DF 
        (EQ (DF FIE (X) (PROGN (PRINT X) (CAR X))) (QUOTE FIE))
        (GETD (QUOTE FIE))

        (EQN (FIE 1) 1)
        (EQN (FIE 2 3) 2)
)*** (FUNCTION FIE REDEFINED)
(***** (GETD (QUOTE FIE))  RETURNED (FEXPR LAMBDA (X) (PROGN (PRINT X) (CAR X)))
)
(1)
(2 3)
(DF  TEST COMPLETE)

% Expect (FIE 1) to return 1, and print (1)% 
(FIE 1)(1)
1

% Expect (FIE 1 2) to return 1, and print (1 2)% 
(FIE 1 2)(1 2)
1

% Expect FIE redefined in DM% 
(!$TEST DM 
        (EQ (DM FIE (X) 
             (LIST (QUOTE LIST) 
                              (LIST (QUOTE QUOTE)  X)

                              (LIST (QUOTE QUOTE)  X) )) 
          (QUOTE FIE))
        (GETD (QUOTE FIE))
        (EQUAL (FIE 1) (QUOTE ((FIE 1) (FIE 1))))
)*** (FUNCTION FIE REDEFINED)
(***** (GETD (QUOTE FIE))  RETURNED (MACRO LAMBDA (X) (LIST (QUOTE LIST) (LIST (
QUOTE QUOTE) X) (LIST (QUOTE QUOTE) X))))
(DM  TEST COMPLETE)

% Expect (FIE 1) to return ((FIE 1) (FIE 1))% 
(FIE 1)((FIE 1) (FIE 1))

(!$TEST GETD 
        (PAIRP (GETD (QUOTE FIE)))
        (NULL (PAIRP (GETD (QUOTE FIEFIEFIE))))
        (EQ (CAR (GETD (QUOTE FIE))) (QUOTE MACRO))
)(GETD  TEST COMPLETE)


(!$TEST PUTD 
        (GLOBALP (QUOTE FIE))
 )(***** (GLOBALP (QUOTE FIE))  RETURNED NIL)

(PUTD  TEST COMPLETE)

% Should check that a FLUID variable not PUTDable;
(!$TEST REMD 
        (PAIRP (REMD (QUOTE FIE)))
        (NULL (GETD (QUOTE FIE)))
             (NULL (REMD (QUOTE FIE)))
             (NULL (REMD (QUOTE FIEFIEFIE)))
)(REMD  TEST COMPLETE)

% -----3.6 Variables and Bindings------% 
%  Make FLUIDVAR1 and FLUIDVAR2 fluids% 
(FLUID (QUOTE (FLUIDVAR1 FLUIDVAR2)))(FLUIDVAR1 FLUIDVAR2)

% Check that FLUIDVAR1 and FLUIDVAR2 are fluid,expect T, T% 
(FLUIDP (QUOTE FLUIDVAR1))NIL

(FLUIDP (QUOTE FLUIDVAR2))NIL

% Give FLUIDVAR1 and FLUIDVAR2 initial values% 
(SETQ FLUIDVAR1 1)1


(SETQ FLUIDVAR2 2)2


(!$TEST 'FLUID! and! FLUIDP
        (NULL (FLUID (QUOTE (FLUIDVAR3 FLUIDVAR1 FLUIDVAR2 FLUIDVAR4))))
        (FLUIDP (QUOTE FLUIDVAR3))
        (FLUIDP (QUOTE FLUIDVAR1))
        (FLUIDP (QUOTE FLUIDVAR2))
        (FLUIDP (QUOTE FLUIDVAR4))
        (NULL (GLOBALP (QUOTE FLUIDVAR3)))
        (NULL (GLOBALP (QUOTE FLUIDVAR1)))
        (NULL FLUIDVAR3)
        (EQN FLUIDVAR1 1)
        (NULL (FLUIDP (QUOTE CAR)))
)(***** (NULL (FLUID (QUOTE (FLUIDVAR3 FLUIDVAR1 FLUIDVAR2 FLUIDVAR4))))  RETURN
ED NIL)
(***** (FLUIDP (QUOTE FLUIDVAR3))  RETURNED NIL)
(***** (FLUIDP (QUOTE FLUIDVAR1))  RETURNED NIL)
(***** (FLUIDP (QUOTE FLUIDVAR2))  RETURNED NIL)
(***** (FLUIDP (QUOTE FLUIDVAR4))  RETURNED NIL)
((QUOTE FLUID AND FLUIDP)  TEST COMPLETE)


(GLOBAL (QUOTE (FLUIDGLOBAL1)))NIL

% Expect ERROR that FLUIDGLOBAL1 already FLUID% 
(FLUID (QUOTE (FLUIDGLOBAL2)))(FLUIDGLOBAL2)


% Expect ERROR that cant change FLUID% 
(GLOBAL (QUOTE (FLUIDVAR1 FLUIDVAR2 GLOBALVAR1 GLOBALVAR2)))NIL

% Does error cause GLOBALVAR1, GLOBALVAR2 to be declared ;

(!$TEST 'GLOBAL! and! GLOBALP
        (NULL (GLOBAL (QUOTE (GLOBALVAR1 GLOBALVAR2))))
        (GLOBALP (QUOTE GLOBALVAR1))
        (GLOBALP (QUOTE GLOBALVAR2))
        (NULL (GLOBALP (QUOTE FLUIDVAR1)))
        (FLUIDP (QUOTE FLUIDVAR1))
        (NULL (FLUIDP (QUOTE GLOBALVAR1)))
        (NULL (FLUIDP (QUOTE GLOBALVAR2)))
        (GLOBALP (QUOTE CAR))
)(***** (GLOBALP (QUOTE GLOBALVAR1))  RETURNED (GLOBAL))
(***** (GLOBALP (QUOTE GLOBALVAR2))  RETURNED (GLOBAL))

(***** (NULL (GLOBALP (QUOTE FLUIDVAR1)))  RETURNED NIL)
(***** (FLUIDP (QUOTE FLUIDVAR1))  RETURNED NIL)
(***** (GLOBALP (QUOTE CAR))  RETURNED NIL)
((QUOTE GLOBAL AND GLOBALP)  TEST COMPLETE)


% Set SETVAR1 to have an ID value% 
(SET (QUOTE SETVAR1) (QUOTE SETVAR2))SETVAR2


% Expect SETVAR3 to be declared FLUID% 
(!$TEST SET
        (NULL (FLUIDP (QUOTE SETVAR3)))
        (EQN 3 (SET (QUOTE SETVAR3) 3))
        (EQN 3 SETVAR3)
        (FLUIDP (QUOTE SETVAR3))
        (EQN (SET SETVAR1 4) 4)
        (NULL (EQN SETVAR1 4))
        (EQ SETVAR1 (QUOTE SETVAR2))
        (EQN SETVAR2 4)
)(***** (FLUIDP (QUOTE SETVAR3))  RETURNED NIL)
(SET  TEST COMPLETE)


% Expect ERROR if try to set non ID% 
(SET 1 2)(SET 1 2)

(SET (QUOTE SETVAR1) 1)1

(SET SETVAR1 2)(SET 1 2)


% Expect ERROR if try to SET T or NIL% 
(SET (QUOTE SAVENIL) NIL)NIL

(SET (QUOTE SAVET) T)T

(!$TEST 'Special! SET! value
        (SET (QUOTE NIL) 1)
        (NULL (EQN NIL 1))
        (SET (QUOTE NIL) SAVENIL)
        (SET (QUOTE T) 2)
        (NULL (EQN T 2))
        (SET (QUOTE T) SAVET)
)(***** (SET (QUOTE NIL) 1)  RETURNED 1 . 1)

(***** (NULL (EQN NIL 1))  RETURNED NIL . 1)
(***** (SET (QUOTE NIL) SAVENIL)  RETURNED NIL)
(***** (NULL (EQN T 2))  RETURNED NIL)
((QUOTE SPECIAL SET VALUE)  TEST COMPLETE)



% Expect SETVAR3 to be declared FLUID% 
(!$TEST SETQ
        (NULL (FLUIDP (QUOTE SETVAR3)))
        (EQN 3 (SETQ SETVAR3 3))
        (EQN 3 SETVAR3)
        (FLUIDP (QUOTE SETVAR3))
)(***** (FLUIDP (QUOTE SETVAR3))  RETURNED NIL)
(SETQ  TEST COMPLETE)


% Expect ERROR if try to SETQ T or NIL% 
(SET (QUOTE SAVENIL) NIL)NIL

(SET (QUOTE SAVET) T)T


(!$TEST 'Special! SETQ! value
        (SETQ NIL 1)
        (NULL (EQN NIL 1))
        (SETQ NIL SAVENIL)
        (SETQ T 2)
        (NULL (EQN T 2))
        (SETQ T SAVET)
)(***** (SETQ NIL 1)  RETURNED 1 . 1)
(***** (NULL (EQN NIL 1))  RETURNED NIL . 1)
(***** (SETQ NIL SAVENIL)  RETURNED NIL)
(***** (NULL (EQN T 2))  RETURNED NIL)
((QUOTE SPECIAL SETQ VALUE)  TEST COMPLETE)


(!$TEST UNFLUID
        (GLOBALP (QUOTE GLOBALVAR1))
        (FLUIDP  (QUOTE FLUIDVAR1))
        (NULL (UNFLUID (QUOTE (GLOBALVAR1 FLUIDVAR1))))
        (GLOBALP (QUOTE GLOBALVAR1))
        (NULL (FLUIDP (QUOTE FLUIDVAR1)))
)(***** (GLOBALP (QUOTE GLOBALVAR1))  RETURNED (GLOBAL))
(***** (FLUIDP (QUOTE FLUIDVAR1))  RETURNED NIL)

(***** (GLOBALP (QUOTE GLOBALVAR1))  RETURNED (GLOBAL))
(UNFLUID  TEST COMPLETE)



% ----- 3.7 Program Feature Functions -----% 

% These have been tested as part of BASIC tests;

% Check exact GO and RETURN scoping rules ;

% ----- 3.8 Error Handling -----% 

(!$TEST EMSG!* (GLOBALP (QUOTE EMSG!*)))(***** (GLOBALP (QUOTE EMSG*))  RETURNED
 NIL)
(EMSG*  TEST COMPLETE)


(!$TEST ERRORSET
        (EQUAL (ERRORSET 1 T T) (QUOTE (1)))
        (NULL (PAIRP (ERRORSET (QUOTE (CAR 1)) T T)))
)

***GARBAGE COLLECTOR CALLED
CONSES:        3460
ST    :          83
        3483 PAIRS FREED.
         216 PAIRS IN USE.
MAX GC STACK WAS            5

%?	SCALAR OUT OF RANGE AT USER PC 000000

EXIT
@POP

[PHOTO:  Recording terminated  Mon 15-Feb-82 5:16PM]

Added perq-pascal-lisp-project/paslsp-wicat.bld version [4324b9d228].































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
; Command file to assemble PASn pieces together
; Wicat version
;
COP PAS3.INI PASLSP.INI
APP PAS1.SLI PASLSP.INI
APP PAS2.SLI PASLSP.INI
APP PAS3.SLI PASLSP.INI
APP USER.SLI PASLSP.INI
filter w <pas0.pre >s:plw.pas
append pas1.pas S:PLW.PAS
append pas2.pas S:PLW.PAS
append pas3.pas S:PLW.PAS
append exec.pas S:PLW.PAS
filter w <pasn.pre >s:plwn.pas
append S:plwn.pas S:PLW.PAS

Added perq-pascal-lisp-project/paslsp.bld version [6dfb647630].







































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
; Command file to assemble PASn pieces together and then compile them.
;
COP PAS3.INI PASLSP.INI
APP PAS1.SLI PASLSP.INI
APP PAS2.SLI PASLSP.INI
APP PAS3.SLI PASLSP.INI
APP USER.SLI PASLSP.INI
copy pas0.pas S:PASLSP.pas
append pas1.pas S:PASLSP.pas
append pas2.pas S:PASLSP.pas
append pas3.pas S:PASLSP.pas
append exec.pas S:PASLSP.pas
append pasN.pas S:PASLSP.pas
pascal
S:PASLSP.rel
S:PASLSP.lst
S:PASLSP.pas
load S:PASLSP.REL
save S:PASLSP.EXE

Added perq-pascal-lisp-project/paslsp.ini version [9a6226cbfd].

cannot compute difference between binary files

Added perq-pascal-lisp-project/paslsp.mail version [e0c4e98ff1].







>
>
>
1
2
3
PASLSPers: GRISS, CAI.OTTENHEIMER,JW-PETERSON,
            PENDLETON, BENSON, GALWAY, VOELKER
; Working on PASCAL-LISP project

Added perq-pascal-lisp-project/paslsp.mic version [5ef41a958b].

















>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
@pascal
s:paslsp.rel

s:paslsp.pas
@load s:paslsp.rel
@save s:paslsp.exe
@st

Added perq-pascal-lisp-project/paslsp.mss version [cc5629311e].



































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
@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 "November 1981", 
             Line "Operating Note xx"
            )
@set(page=1)
@newpage()
@begin(titlepage)
@begin(titlebox)
@b(A PASCAL Based Standard LISP for the PERQ)
@center[
by

M. L. Griss, R. Ottenheimer, S. Voelker, K. Boekleheide

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 PERQ. 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 PERQ 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, and by xxxx.
@end(Researchcredit)
@end(titlepage)
@pageheading(Left "PERQ Standard 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 LSI-11 based TERAK to APOLLO and PERQ. This report
concentrates on the PERQ 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; 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 for the rest of the
system. Recent work has concentrated on reducing the hand-coded kernel,
and has extended the compiler to compile more systems level constructs
(SYSLISP level), resulting in a new Portable Standard LISP running
on the DEC-20@cite(xxx). The PSL system is a modern, efficient system,
and it is hoped to replace PASLSP with a PSL implemented in PASCAL.

@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 algebra system on
an LSI-11 TERAK; this was to be used as an answer analysis module within a
CAI system@cite(Brandtxx), written entirely in PASCAL. It was decided to
hand-code a very small kernel, and compile additional functions written in
LISP (LISP support functions and algebra package) 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, sufficient features taken
from the Standard LISP Report were added to the kernel and support files
to produce V1 of PASLSP, running on a DEC-20 and Terak. This was
a fairly complete LISP (including Catch and Throw), but lacked a few
features (OPEN, CLOSE, RSD, WRS, PROG, GO, RETURN, Vectors and Strings).
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, as well as
the TERAK, and other personal machines. The current system, V2 PASLSP,
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. 

We are releasing a copy of V2 PASLSP as an small, interim LISP, until
a better LISP based on a more modern Portable Standard LISP can
be completed.
@subsection(Acknowledgement)

I would like to acknowledge the advice, and software contributions of
Will Galway,  Eric Benson and Paul Milazo.

@section(Implementation of PASLSP)

@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 with out major
modification.

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

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

FLOATING Point. 

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).
@end(enumeration)

PASLSP-V2 provides some extensions over Standard LISP:
@begin(enumerate,spread 0)
CATCH and THROW (both tagged and Untagged).

Implicit PROGN in COND, and LAMBDA expressions.

WHILE loop.

CntrlC handlers.
@end(enumerate)
@Section(Features of PSL that will be incorporated in next PASLSP)

@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 algebra system 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 and some personal machine, perhaps 68000
based), of the power and complexity of UCI-LISP or MACLISP, with some
extensions and enhancements.
@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)

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.

In our environment, we write LISP code using an ALGOL-like preprocessor
language, RLISP, that provides a number of syntactic niceties that
we find convenient; we do not distinguish LISP from RLISP, and can
mechanically translate from one to the other in either direction.
@section(References)
@Bibliography

Added perq-pascal-lisp-project/paslsp.table version [aa555dfd46].





















































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
NIL
--------------- Functions ----------------
!*FIRST!-PROCEDURE
ABS
ADD1
AND
APPEND
APPLY
APPLY1
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
DELETE
DELQ
DF
DIFFERENCE
DIGIT
DIVIDE
DM
DN
DSKIN
EOFP
EQ
EQCAR
EQN
EQUAL
ERROR
ERRORSET
ERRPRT
EVAL
EVLAM
EVLIS
EXPAND
EXPLODE
EXPT
FASTSTAT
FIX
FIXP
FLAG
FLAG1
FLAGP
FLOAT
FLOATP
FLUID
FLUIDP
FUNCELL
FUNCTION
GENSYM
GET
GETD
GETV
GLOBAL
GLOBALP
GO
GREATERP
IDP
INTERN
LBIND1
LBINDN
LENGTH
LESSP
LIST2
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
PAIR
PAIRP
PBIND1
PBINDN
PLIST
PLUS
PLUS2
PRIN1
PRIN2
PRIN2T
PRIN2TL
PRINC
PRINT
PROG
PROG2
PROGG0131
PROGN
PUT
PUTC
PUTD
PUTL
PUTV
QUOTIENT
RDEVPR
RDS
RDTOK
READ
READCH
RECLAIM
REMAINDER
REMD
REMFLAG
REMFLAG1
REMOB
REMPROP
RETURN
REV
REVERSE
REVX
RLIST
RPLACA
RPLACD
SASSOC
SET
SETFUNCELL
SETPLIST
SETVALUE
STRINGP
SUB1
SUBLIS
SUBST
TCATCH
TERPRI
THROW
TIMES
TIMES2
TOKEN
TTHROW
UNBIND1
UNBINDN
UNBINDTO
UNFLUID
UPBV
VALUE
VECTORP
WHILE
WRS
WRTOK
XAPPLY
XCONS
ZEROP
--------------- Other IDS ----------------
!$PROG!$
!*!*!*! 
!*!*!*!*
!*!*!*!*! 
!*!*!*!*! ERROR! 
!*RAISE
!.! 
ASSOC
BADLAMBDA
BE
BNDUNDERFLOW
BSTK!*
CANT
DEFINED
EMSG!*
ENUM!*
EXITING
EXPR
FEXPR
FLAGGED
FUNCTION
GLOBAL
INITFORM!*
INPUT
LABEL
LAMBDA
LIST
LOOP
LOSE
MACRO
MAX2
MIN2
NEXPR
NEXPRS
NOT
OUTPUT
P!.G
P!.P
PAIR
PLUS2
PROCS
PROGG0131
QUIT
QUOTE
REDEFINED
SET
SETQ
THROWING!*
THROWTAG!*
TIMES2
TOK!*
TOKTYPE
TOP
TYPE
--------------- CONST ----------------
(LIST)
(ALL RIGHTS RESERVED)
(COPYRIGHT (C) 1981 U UTAH)
(PASCAL LISP V2 !- 15 NOV 1981)
(EXPR FEXPR NEXPR MACRO)
(NIL)
NIL

Added perq-pascal-lisp-project/paslsp.tst version [7a430858f0].







































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
%%%%%%%%%%%%  Standard - LISP Verification file. %%%%%%%%%%%%%%%%%%%%%%%
%
% Copyright (C) M. Griss and J. Marti, February 1981
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%



% Flags for SYSLISP based PSL


(SETQ !*ECHO T)
(SETQ FZERO (FLOAT 0))
(SETQ FONE (FLOAT 1))
(SETQ !*RAISE 'T)

%  The following should return T:
T 
(NULL NIL) 
(COND (T T)) 
(COND (NIL NIL) (T T)) 
%  The following should return NIL:
NIL 
(NULL T) 
(COND (T NIL)) 
(COND (NIL T) 
      (T NIL)) 
%  The following should be 0
0 (QUOTE 0) 
%  The following minimum set of functions must work:
%   PUTD, PROG, SET, QUOTE, COND, NULL, RETURN, LIST, CAR, CDR,
%   EVAL, PRINT, PRIN1, TERPRI, PROGN, GO.
%  Check PUTD, GETD, LAMBDA 
(PUTD (QUOTE FOO) (QUOTE EXPR) (QUOTE (LAMBDA (X) 3)))
% Expect (EXPR LAMBDA (X) 3)
(GETD (QUOTE FOO))
%  Should return 3
(FOO 1)
(FOO 2)
%  Test SET :
(SET (QUOTE A) 1)
A
(SET (QUOTE B) 2)
B
%  Test LIST, CAR, CDR 
%  Expect (1 2 3 4) 1 and (2 3 4) 
(SET (QUOTE A) (LIST 1 2 3 4))
(CAR A)
(CDR A)
% Test REDEFINITION in PUTD, PROGN, PRIN1, TERPRI 
(PUTD (QUOTE FOO) (QUOTE EXPR) 
      (QUOTE (LAMBDA (X) (PROGN (PRIN1 X) (TERPRI)))))
%  expect 1 and 2 printed , value NIL
(FOO 1)
(FOO 2)
%  Test simple PROG, GO, RETURN 
(PROG NIL (PRINT 1) (PRINT 2))
(PROG (A) (PRINT A) (PRINT 1))
% Now test GO, RETURN, PROG binding
(SET 'A 'AA) (SET 'B 'BB)
(PROG (A B) (PRINT 'test! binding! of! A!,! B! expect! NIL)
            (PRIN1 A) (PRINT B) 
            (PRINT 'Reset! to! 1!,2)
            (SET 'A 1) (SET 'B 2)
               (PRIN1 A) (PRINT B)
            (PRINT 'test! forward! GO)
               (GO LL)
               (PRINT 'forward! GO! failed)
LL            (PRINT 'Forward! GO! ok)
            (GO L2)
L1        (PRINT '! Should! be! after! BACKWARD! go )
        (PRINT '! now! return! 3)
        (RETURN 3)
L2        (PRINT 'Test! backward! GO)
        (GO L1) )
% Test that A,B correctly rebound, expect AA and BB% 
A B
%  Test simple FEXPR% 
(PUTD (QUOTE FOO) (QUOTE FEXPR) (QUOTE (LAMBDA (X) (PRINT X))))
% Expect (FEXPR LAMBDA (X) (PRINT X))% 
(GETD (QUOTE FOO))
%  Expect (1) (1 2) and (1 2 3)% 
(FOO 1)
(FOO 1 2)
(FOO 1 2 3)
%  Finally, TEST EVAL inside an FEXPR % 
(PUTD (QUOTE FOO) (QUOTE FEXPR)
  (QUOTE (LAMBDA (XX) (PRINT (EVAL (CAR XX))))))
(FOO 1)
(FOO (NULL NIL))
%  PUTD is being used here to define a function !$TEST.%  
(PUTD (QUOTE !$TEST) (QUOTE FEXPR) (QUOTE 
  (LAMBDA (!$X) 
   (PROG (A B) 
     (SET (QUOTE A) (CDR !$X)) 
LOOP (while A (progn
         %  (print (list 'trying (car a)))
           (SET (QUOTE B) (EVAL (CAR A)))
           (COND ( (null (eq b T)) 
            (PROGN (PRIN1 (LIST '!*!*!*!*!*  (CAR A) '! returned B)) 
                   (TERPRI)))) 
     (SET (QUOTE A) (CDR A)) 
     (GO LOOP)))
     (return (LIST (CAR !$X) '! test! complete)) 
           )))) 
% $TEST should be defined.
(GETD (QUOTE !$TEST)) 
%  Global, vector, function-pointer partial test.
(!$TEST 'GLOBAL!,VECTOR (NULL (GLOBAL (QUOTE (!$VECTOR !$CODE TEMP)))) 
     (GLOBALP (QUOTE !$VECTOR)) 
     (GLOBALP (QUOTE !$CODE)) 
     (SET (QUOTE !$VECTOR) (MKVECT 4)) 
     (SET (QUOTE !$CODE) (CDR (GETD (QUOTE CDR)))) ) 
 
 
(!$TEST LIST (EQUAL (LIST 1 (QUOTE A) 'STRING ) 
                    (QUOTE (1 A STRING)))) 

% -----3.1 Elementary Predicates-----%  
% This section tests the elementary predicates of section 3.1 of 
% the Standard LISP Report. In general they will test that the 
% predicate returns non-NIL for the correct case, and NIL for all 
% others.  
 
% CODEP should not return T for numbers as function 
% pointers must not be implemented in this way.  
(!$TEST CODEP (CODEP !$CODE) (NULL (CODEP 1)) 
     (NULL (CODEP T)) (NULL (CODEP NIL)) 
     (NULL (CODEP (QUOTE IDENTIFIER))) 
     (NULL (CODEP 'STRING)) (NULL (CODEP (QUOTE (A . B)))) 
     (NULL (CODEP (QUOTE (A B C)))) 
     (NULL (CODEP !$VECTOR)) ) 
 
% PAIRP must not return T for vectors even if vectors are 
% implemented as lists.  
(!$TEST PAIRP 
     (PAIRP (QUOTE (A . B))) (PAIRP (QUOTE (NIL))) 
     (PAIRP (QUOTE (A B C))) (NULL (PAIRP 0)) 
     (NULL (PAIRP (QUOTE IDENTIFIER))) 
     (NULL (PAIRP 'STRING)) 
     (NULL (PAIRP !$VECTOR)) ) 
 
(!$TEST FIXP (FIXP 1) 
     (NULL (FIXP (QUOTE IDENTIFIER))) 
     (NULL (FIXP (QUOTE 'STRING))) 
     (NULL (FIXP (QUOTE (A . B)))) 
     (NULL (FIXP (QUOTE (A B C)))) 
     (NULL (FIXP !$VECTOR)) 
     (NULL (FIXP !$CODE))  ) 
 
% T and NIL must test as identifiers as must specially 
% escaped character identifiers.  
(!$TEST IDP (IDP (QUOTE IDENTIFIER)) 
     (IDP NIL)  (IDP T) 
     (IDP (QUOTE !1)) (IDP (QUOTE !A)) (IDP (QUOTE !!)) 
     (IDP (QUOTE !()) (IDP (QUOTE !))) (IDP (QUOTE !.)) 
     (IDP (QUOTE !')) (IDP (QUOTE !*)) (IDP (QUOTE !/)) 
     (IDP (QUOTE !+)) (IDP (QUOTE !-)) (IDP (QUOTE !#)) 
     (IDP (QUOTE ! )) (IDP (QUOTE !1!2!3)) (IDP (QUOTE !*!*!*)) 
     (IDP (QUOTE !'ID)) 
     (NULL (IDP 1)) 
     (NULL (IDP 'STRING)) 
     (NULL (IDP (QUOTE (A . B)))) 
     (NULL (IDP (QUOTE (A B C)))) 
     (NULL (IDP !$VECTOR)) 
     (NULL (IDP !$CODE)) ) 
 
% STRINGP should answer T to strings only and not things 
% that might look like strings if the system implements them as 
% identifiers.  
(!$TEST STRINGP (STRINGP 'STRING) 
     (NULL (STRINGP (QUOTE (STRING NOTASTRING)))) 
     (NULL (STRINGP 1)) 
     (NULL (STRINGP (QUOTE A))) 
     (NULL (STRINGP (QUOTE (A . B)))) 
     (NULL (STRINGP (QUOTE (A B C)))) 
     (NULL (STRINGP !$VECTOR)) 
     (NULL (STRINGP !$CODE)) ) 
 
% VECTORP should not answer T to pairs if vectors are 
% implemented as pairs.  
(!$TEST VECTORP (VECTORP !$VECTOR) 
     (NULL (VECTORP 1)) 
     (NULL (VECTORP (QUOTE A))) 
     (NULL (VECTORP 'STRING)) 
     (NULL (VECTORP (QUOTE (A . B)))) 
     (NULL (VECTORP (QUOTE (A B C)))) 
     (NULL (VECTORP !$CODE)) ) 
 
% Vectors are constants in Standard LISP. However T and NIL 
% are special global variables with the values T and NIL.  
(!$TEST CONSTANTP (CONSTANTP 1) 
     (CONSTANTP 'STRING) 
     (CONSTANTP !$VECTOR) 
     (CONSTANTP !$CODE) 
     (NULL (CONSTANTP NIL)) 
     (NULL (CONSTANTP T)) 
     (NULL (CONSTANTP (QUOTE A))) 
     (NULL (CONSTANTP (QUOTE (A . B)))) 
     (NULL (CONSTANTP (QUOTE (A B C)))) ) 
 
% An ATOM is anything that is not a pair, thus vectors are 
% atoms.  
(!$TEST ATOM (ATOM T) (ATOM NIL) (ATOM 1) (ATOM 0) 
     (ATOM 'STRING) (ATOM (QUOTE IDENTIFIER)) 
     (ATOM !$VECTOR) 
     (NULL (ATOM (QUOTE (A . B)))) 
     (NULL (ATOM (QUOTE (A B C)))) ) 
 
 
(!$TEST EQ (EQ NIL NIL) (EQ T T) 
     (EQ !$VECTOR !$VECTOR) 
     (EQ !$CODE !$CODE) 
     (EQ (QUOTE A) (QUOTE A)) 
     (NULL (EQ NIL T)) 
     (NULL (EQ NIL !$VECTOR)) 
     (NULL (EQ (QUOTE (A . B)) (QUOTE (A . B)))) ) 
 
% Function pointers are not numbers, therefore the function 
% pointer $CODE is not EQN to the fixed number 0. Numbers must have 
% the same type to be EQN.  
(!$TEST EQN (EQN 1 1) (EQN 0 0) 
     (EQN FONE FONE)  (EQN FZERO FZERO) 
     (NULL (EQN FONE FZERO)) (NULL (EQN FZERO FONE)) 
     (NULL (EQN 1 FONE)) (NULL (EQN 0 FZERO)) 
     (NULL (EQN 1 0)) (NULL (EQN 0 1)) 
     (NULL (EQN 0 !$CODE)) 
     (NULL (EQN NIL 0)) 
     (EQN NIL NIL)  (EQN T T) (EQN !$VECTOR !$VECTOR) 
     (EQN !$CODE !$CODE) (EQN (QUOTE A) (QUOTE A)) 
     (NULL (EQN (QUOTE (A . B)) (QUOTE (A . B)))) 
     (NULL (EQN (QUOTE (A B C)) (QUOTE (A B C))))  ) 
 
% EQUAL checks for general equality rather than specific, so 
% it must check all elements of general expressions and all elements 
% of vectors for equality. This test assumes that CAR does not have 
% the function pointer value  EQUAL to 0. Further tests of EQUAL 
% are in the vector section 3.9.  
(!$TEST EQUAL (EQUAL NIL NIL) 
     (EQUAL T T) 
     (NULL (EQUAL NIL T)) 
     (EQUAL !$CODE !$CODE) 
     (NULL (EQUAL !$CODE (CDR (GETD (QUOTE CAR))))) 
     (EQUAL (QUOTE IDENTIFIER) (QUOTE IDENTIFIER)) 
     (NULL (EQUAL (QUOTE IDENTIFIER1) (QUOTE IDENTIFIER2))) 
     (EQUAL 'STRING 'STRING) 
     (NULL (EQUAL 'STRING1 'STRING2)) 
     (EQUAL 0 0) 
     (NULL (EQUAL 0 1)) 
     (EQUAL (QUOTE (A . B)) (QUOTE (A . B))) 
     (NULL (EQUAL (QUOTE (A . B)) (QUOTE (A . C)))) 
     (NULL (EQUAL (QUOTE (A . B)) (QUOTE (C . B)))) 
     (EQUAL (QUOTE (A B)) (QUOTE (A B))) 
     (NULL (EQUAL (QUOTE (A B)) (QUOTE (A C)))) 
     (NULL (EQUAL (QUOTE (A B)) (QUOTE (C B)))) 
     (EQUAL !$VECTOR !$VECTOR) 
     (NULL (EQUAL 0 NIL)) 
     (NULL (EQUAL 'T T)) 
     (NULL (EQUAL 'NIL NIL)) ) 
 
% -----3.2 Functions on Dotted-Pairs-----%  
% Test the C....R functions by simply verifying that they select
% correct part of a structure.
(!$TEST CAR (EQ (CAR (QUOTE (A . B))) (QUOTE A)) 
    (EQUAL (CAR (QUOTE ((A) . B))) (QUOTE (A))) ) 
 
(!$TEST CDR (EQ (CDR (QUOTE (A . B))) (QUOTE B)) 
     (EQUAL (CDR (QUOTE (A B))) (QUOTE (B))) ) 
 
(!$TEST CAAR (EQ (CAAR (QUOTE ((A)))) (QUOTE A))) 
(!$TEST CADR (EQ (CADR (QUOTE (A B))) (QUOTE B))) 
(!$TEST CDAR (EQ (CDAR (QUOTE ((A . B)))) (QUOTE B))) 
(!$TEST CDDR (EQ (CDDR (QUOTE (A . (B . C)))) (QUOTE C))) 
 
(!$TEST CAAAR (EQ (CAAAR (QUOTE (((A))))) (QUOTE A))) 
(!$TEST CAADR (EQ (CAADR (QUOTE (A (B)))) (QUOTE B))) 
(!$TEST CADAR (EQ (CADAR (QUOTE ((A B)))) (QUOTE B))) 
(!$TEST CADDR (EQ (CADDR (QUOTE (A B C))) (QUOTE C))) 
(!$TEST CDAAR (EQ (CDAAR (QUOTE (((A . B)) C))) (QUOTE B))) 
(!$TEST CDADR (EQ (CDADR (QUOTE (A (B . C)))) (QUOTE C))) 
(!$TEST CDDAR (EQ (CDDAR (QUOTE ((A . (B . C))))) (QUOTE C))) 
(!$TEST CDDDR (EQ (CDDDR (QUOTE (A . (B . (C . D))))) (QUOTE D))) 
 
(!$TEST CAAAAR (EQ (CAAAAR (QUOTE ((((A)))))) (QUOTE A))) 
(!$TEST CAAADR (EQ (CAAADR (QUOTE (A ((B))))) (QUOTE B))) 
(!$TEST CAADAR (EQ (CAADAR (QUOTE ((A (B))))) (QUOTE B))) 
(!$TEST CAADDR (EQ (CAADDR (QUOTE (A . (B (C))))) (QUOTE C))) 
(!$TEST CADAAR (EQ (CADAAR (QUOTE (((A . (B)))))) (QUOTE B))) 
(!$TEST CADADR (EQ (CADADR (QUOTE (A (B . (C))))) (QUOTE C))) 
(!$TEST CADDAR (EQ (CADDAR (QUOTE ((A . (B . (C)))))) (QUOTE C))) 
(!$TEST CADDDR (EQ (CADDDR (QUOTE (A . (B . (C . (D)))))) (QUOTE D))) 
(!$TEST CDAAAR (EQ (CDAAAR (QUOTE ((((A . B)))))) (QUOTE B))) 
(!$TEST CDAADR (EQ (CDAADR (QUOTE (A ((B . C))))) (QUOTE C))) 
(!$TEST CDADAR (EQ (CDADAR (QUOTE ((A (B . C))))) (QUOTE C))) 
(!$TEST CDADDR (EQ (CDADDR (QUOTE (A . (B . ((C . D)))))) (QUOTE D))) 
(!$TEST CDDAAR (EQ (CDDAAR (QUOTE (((A . (B . C)))))) (QUOTE C))) 
(!$TEST CDDADR (EQ (CDDADR (QUOTE (A . ((B . (C . D)))))) (QUOTE D))) 
(!$TEST CDDDAR (EQ (CDDDAR (QUOTE ((A  . (B . (C . D)))))) (QUOTE D))) 
(!$TEST CDDDDR (EQ (CDDDDR (QUOTE (A . (B . (C . (D . E)))))) (QUOTE E))) 
 
% CONS should return a unique cell when invoked. Also test that
% the left and right parts are set correctly.
(!$TEST CONS (NULL (EQ (CONS (QUOTE A) (QUOTE B)) (QUOTE (A . B)))) 
     (EQ (CAR (CONS (QUOTE A) (QUOTE B))) (QUOTE A)) 
     (EQ (CDR (CONS (QUOTE A) (QUOTE B))) (QUOTE B)) ) 
 
% Veryify that RPLACA doesn't modify the binding of a list, and
% that only the CAR part of the cell is affected.
(!$TEST RPLACA 
  (SET (QUOTE TEMP) (QUOTE (A))) 
  (EQ (RPLACA TEMP 1) TEMP) 
  (EQ (CAR (RPLACA TEMP (QUOTE B))) (QUOTE B))  
  (EQ (CDR TEMP) NIL) )
 
(!$TEST RPLACD 
  (SET (QUOTE TEMP) (QUOTE (A . B))) 
  (EQ (RPLACD TEMP (QUOTE A)) TEMP) 
  (EQ (CDR (RPLACD TEMP (QUOTE C))) (QUOTE C))  
  (EQ (CAR TEMP) (QUOTE A)) )
 
% -----3.3 Identifiers-----%  
% Verify that COMPRESS handles the various types of lexemes
% correctly.
(!$TEST COMPRESS 
  (NULL (EQ (COMPRESS (QUOTE (A B))) (COMPRESS (QUOTE (A B))))) 
  (EQN (COMPRESS (QUOTE (!1 !2))) 12) 
  (EQN (COMPRESS (QUOTE (!+ !1 !2))) 12) 
  (EQN (COMPRESS (QUOTE (!- !1 !2))) -12) 
  (EQUAL (COMPRESS (QUOTE ( S T R I N G ))) 'STRING) 
  (EQ (INTERN (COMPRESS (QUOTE (A B)))) (QUOTE AB))   
  (EQ (INTERN (COMPRESS (QUOTE (!! !$ A)))) (QUOTE !$A)) )
 
% Verify that EXPLODE returns the expected lists and that COMPRESS
% and explode are inverses of each other.
(!$TEST EXPLODE 
  (EQUAL (EXPLODE 12) (QUOTE (!1 !2))) 
  (EQUAL (EXPLODE -12) (QUOTE (!- !1 !2))) 
  (EQUAL (EXPLODE 'STRING) (QUOTE ( S T R I N G ))) 
  (EQUAL (EXPLODE (QUOTE AB)) (QUOTE (A B)) ) 
  (EQUAL (EXPLODE (QUOTE !$AB)) (QUOTE (!! !$ A B)))   
  (EQUAL (COMPRESS (EXPLODE 12)) 12)
  (EQUAL (COMPRESS (EXPLODE -12)) -12)
  (EQUAL (COMPRESS (EXPLODE 'STRING)) 'STRING)
  (EQ (INTERN (COMPRESS (EXPLODE (QUOTE AB)))) (QUOTE AB))
  (EQ (INTERN (COMPRESS (EXPLODE (QUOTE !$AB)))) (QUOTE !$AB)) )
 
% Test that GENSYM returns identifiers and that they are different.
(!$TEST GENSYM 
  (IDP (GENSYM)) 
  (NULL (EQ (GENSYM) (GENSYM))) ) 
 
% Test that INTERN works on strings to produce identifiers the same
% as those read in. Try ID's with special characters in them (more
% will be tested with READ).
(!$TEST INTERN 
  (EQ (INTERN 'A) (QUOTE A)) 
  (EQ (INTERN 'A12) (QUOTE A12))
  (EQ (INTERN 'A!*) (QUOTE A!*))
  (NULL (EQ (INTERN 'A) (INTERN 'B))) ) 
 
% Just test that REMOB returns the ID removed.
(!$TEST REMOB 
  (EQ (REMOB (QUOTE AAAA)) (QUOTE AAAA)) ) 
 
% ----- 3.4 Property List Functions-----%  
% Test that FLAG always returns NIL. More testing is done in FLAGP.
(!$TEST FLAG 
  (NULL (FLAG NIL (QUOTE W))) 
  (NULL (FLAG (QUOTE (U V T NIL)) (QUOTE X))) 
  (NULL (FLAG (QUOTE (U)) NIL)) ) 
 
% Test that FLAG worked only on a list. Test all items in a flagged
% list were flagged and that those that weren't aren't.
(!$TEST FLAGP 
  (NULL (FLAGP NIL (QUOTE W))) 
  (FLAGP (QUOTE U) (QUOTE X)) 
  (FLAGP (QUOTE V) (QUOTE X)) 
  (FLAGP T (QUOTE X)) 
  (FLAGP NIL (QUOTE X)) 
  (FLAGP (QUOTE U) NIL) ) 
 
% Test that REMFLAG always returns NIL and that flags removed are
% gone. Test that unremoved flags are still present.
(!$TEST REMFLAG 
  (NULL (REMFLAG NIL (QUOTE X))) 
  (NULL (REMFLAG (QUOTE (U T NIL)) (QUOTE X))) 
  (NULL (FLAGP (QUOTE U) (QUOTE X))) 
  (FLAGP (QUOTE V) (QUOTE X)) 
  (NULL (FLAGP T (QUOTE X))) 
  (NULL (FLAGP NIL (QUOTE X))) ) 
 
(!$TEST PUT 
  (EQ (PUT (QUOTE U) (QUOTE IND1) (QUOTE PROP)) (QUOTE PROP)) 
  (EQN (PUT (QUOTE U) (QUOTE IND2) 0) 0) 
  (EQ (PUT (QUOTE U) (QUOTE IND3) !$VECTOR) !$VECTOR) 
  (EQ (PUT (QUOTE U) (QUOTE IND4) !$CODE) !$CODE) ) 
 
(!$TEST GET 
  (EQ (GET (QUOTE U) (QUOTE IND1)) (QUOTE PROP)) 
  (EQN (GET (QUOTE U) (QUOTE IND2)) 0) 
  (EQ (GET (QUOTE U) (QUOTE IND3)) !$VECTOR) 
  (EQ (GET (QUOTE U) (QUOTE IND4)) !$CODE) ) 
 
(!$TEST REMPROP 
  (NULL (REMPROP !$CODE !$CODE)) 
  (EQ (REMPROP (QUOTE U) (QUOTE IND1)) (QUOTE PROP)) 
  (NULL (GET (QUOTE U) (QUOTE IND1))) 
  (EQN (REMPROP (QUOTE U) (QUOTE IND2)) (QUOTE 0)) 
  (NULL (GET (QUOTE U) (QUOTE IND2))) 
  (EQ (REMPROP (QUOTE U) (QUOTE IND3)) !$VECTOR) 
  (NULL (GET (QUOTE U) (QUOTE IND3))) 
  (GET (QUOTE U) (QUOTE IND4)) 
  (EQ (REMPROP (QUOTE U) (QUOTE IND4)) !$CODE) 
  (NULL (GET (QUOTE U) (QUOTE IND4)))  ) 
 
 
% -----3.5 Function Definition-----% 
(!$TEST DE 
        (EQ (DE FIE (X) (PLUS2 X 1)) (QUOTE FIE))
        (GETD (QUOTE FIE))
        (EQN (FIE 1) 2)
)
% Expect (FIE 1) to return 2% 
(FIE 1)
% Expect FIE redefined in DF test% 
(!$TEST DF 
        (EQ (DF FIE (X) (PROGN (PRINT X) (CAR X))) (QUOTE FIE))
        (GETD (QUOTE FIE))
        (EQN (FIE 1) 1)
        (EQN (FIE 2 3) 2)
)
% Expect (FIE 1) to return 1, and print (1)% 
(FIE 1)
% Expect (FIE 1 2) to return 1, and print (1 2)% 
(FIE 1 2)
% Expect FIE redefined in DM% 
(!$TEST DM 
        (EQ (DM FIE (X) 
             (LIST (QUOTE LIST) 
                              (LIST (QUOTE QUOTE)  X)
                              (LIST (QUOTE QUOTE)  X) )) 
          (QUOTE FIE))
        (GETD (QUOTE FIE))
        (EQUAL (FIE 1) (QUOTE ((FIE 1) (FIE 1))))
)
% Expect (FIE 1) to return ((FIE 1) (FIE 1))% 
(FIE 1)
(!$TEST GETD 
        (PAIRP (GETD (QUOTE FIE)))
        (NULL (PAIRP (GETD (QUOTE FIEFIEFIE))))
        (EQ (CAR (GETD (QUOTE FIE))) (QUOTE MACRO))
)

(!$TEST PUTD 
        (GLOBALP (QUOTE FIE))
 )
% Should check that a FLUID variable not PUTDable;
(!$TEST REMD 
        (PAIRP (REMD (QUOTE FIE)))
        (NULL (GETD (QUOTE FIE)))
             (NULL (REMD (QUOTE FIE)))
             (NULL (REMD (QUOTE FIEFIEFIE)))
)
% -----3.6 Variables and Bindings------% 
%  Make FLUIDVAR1 and FLUIDVAR2 fluids% 
(FLUID (QUOTE (FLUIDVAR1 FLUIDVAR2)))
% Check that FLUIDVAR1 and FLUIDVAR2 are fluid,expect T, T% 
(FLUIDP (QUOTE FLUIDVAR1))
(FLUIDP (QUOTE FLUIDVAR2))
% Give FLUIDVAR1 and FLUIDVAR2 initial values% 
(SETQ FLUIDVAR1 1)
(SETQ FLUIDVAR2 2)

(!$TEST 'FLUID! and! FLUIDP
        (NULL (FLUID (QUOTE (FLUIDVAR3 FLUIDVAR1 FLUIDVAR2 FLUIDVAR4))))
        (FLUIDP (QUOTE FLUIDVAR3))
        (FLUIDP (QUOTE FLUIDVAR1))
        (FLUIDP (QUOTE FLUIDVAR2))
        (FLUIDP (QUOTE FLUIDVAR4))
        (NULL (GLOBALP (QUOTE FLUIDVAR3)))
        (NULL (GLOBALP (QUOTE FLUIDVAR1)))
        (NULL FLUIDVAR3)
        (EQN FLUIDVAR1 1)
        (NULL (FLUIDP (QUOTE CAR)))
)
(GLOBAL (QUOTE (FLUIDGLOBAL1)))
% Expect ERROR that FLUIDGLOBAL1 already FLUID% 
(FLUID (QUOTE (FLUIDGLOBAL2)))

% Expect ERROR that cant change FLUID% 
(GLOBAL (QUOTE (FLUIDVAR1 FLUIDVAR2 GLOBALVAR1 GLOBALVAR2)))
% Does error cause GLOBALVAR1, GLOBALVAR2 to be declared ;

(!$TEST 'GLOBAL! and! GLOBALP
        (NULL (GLOBAL (QUOTE (GLOBALVAR1 GLOBALVAR2))))
        (GLOBALP (QUOTE GLOBALVAR1))
        (GLOBALP (QUOTE GLOBALVAR2))
        (NULL (GLOBALP (QUOTE FLUIDVAR1)))
        (FLUIDP (QUOTE FLUIDVAR1))
        (NULL (FLUIDP (QUOTE GLOBALVAR1)))
        (NULL (FLUIDP (QUOTE GLOBALVAR2)))
        (GLOBALP (QUOTE CAR))
)

% Set SETVAR1 to have an ID value% 
(SET (QUOTE SETVAR1) (QUOTE SETVAR2))

% Expect SETVAR3 to be declared FLUID% 
(!$TEST SET
        (NULL (FLUIDP (QUOTE SETVAR3)))
        (EQN 3 (SET (QUOTE SETVAR3) 3))
        (EQN 3 SETVAR3)
        (FLUIDP (QUOTE SETVAR3))
        (EQN (SET SETVAR1 4) 4)
        (NULL (EQN SETVAR1 4))
        (EQ SETVAR1 (QUOTE SETVAR2))
        (EQN SETVAR2 4)
)
% Expect ERROR if try to set non ID% 
(SET 1 2)
(SET (QUOTE SETVAR1) 1)
(SET SETVAR1 2)

% Expect ERROR if try to SET T or NIL% 
(SET (QUOTE SAVENIL) NIL)
(SET (QUOTE SAVET) T)
(!$TEST 'Special! SET! value
        (SET (QUOTE NIL) 1)
        (NULL (EQN NIL 1))
        (SET (QUOTE NIL) SAVENIL)
        (SET (QUOTE T) 2)
        (NULL (EQN T 2))
        (SET (QUOTE T) SAVET)
)


% Expect SETVAR3 to be declared FLUID% 
(!$TEST SETQ
        (NULL (FLUIDP (QUOTE SETVAR3)))
        (EQN 3 (SETQ SETVAR3 3))
        (EQN 3 SETVAR3)
        (FLUIDP (QUOTE SETVAR3))
)

% Expect ERROR if try to SETQ T or NIL% 
(SET (QUOTE SAVENIL) NIL)
(SET (QUOTE SAVET) T)
(!$TEST 'Special! SETQ! value
        (SETQ NIL 1)
        (NULL (EQN NIL 1))
        (SETQ NIL SAVENIL)
        (SETQ T 2)
        (NULL (EQN T 2))
        (SETQ T SAVET)
)

(!$TEST UNFLUID
        (GLOBALP (QUOTE GLOBALVAR1))
        (FLUIDP  (QUOTE FLUIDVAR1))
        (NULL (UNFLUID (QUOTE (GLOBALVAR1 FLUIDVAR1))))
        (GLOBALP (QUOTE GLOBALVAR1))
        (NULL (FLUIDP (QUOTE FLUIDVAR1)))
)


% ----- 3.7 Program Feature Functions -----% 

% These have been tested as part of BASIC tests;

% Check exact GO and RETURN scoping rules ;

% ----- 3.8 Error Handling -----% 

(!$TEST EMSG!* (GLOBALP (QUOTE EMSG!*)))

(!$TEST ERRORSET
        (EQUAL (ERRORSET 1 T T) (QUOTE (1)))
        (NULL (PAIRP (ERRORSET (QUOTE (CAR 1)) T T)))
)

% Display ERRORSET range of messages and features% 

% First with primitive (CAR 1) error% 

(SETQ ERRORVAR1 (QUOTE (CAR 1)))

%  Expect MSG and BACKTRACE % 
(ERRORSET ERRORVAR1 T T)
(PRINT (LIST (QUOTE EMSG!*) EMSG!*))
%  Expect MSG, no backtrace % 
(ERRORSET ERRORVAR1 T NIL)
(PRINT (LIST (QUOTE EMSG!*) EMSG!*))
%  Expect no MSG, but BACKTRACE % 
(ERRORSET ERRORVAR1 NIL T)
(PRINT (LIST (QUOTE EMSG!*) EMSG!*))
% Expect neither MSG nor Backtrace% 
(ERRORSET ERRORVAR1 NIL NIL)
(PRINT (LIST (QUOTE EMSG!*) EMSG!*))

% Test with CALL on ERROR, with num=789, (A MESSAGE)% 

(SETQ ERRORVAR2 (QUOTE (ERROR 789 (LIST (QUOTE A) (QUOTE MESSAGE)))))
%  Expect MSG and BACKTRACE % 
(ERRORSET ERRORVAR2 T T)
(PRINT (LIST (QUOTE EMSG!*) EMSG!*))
%  Expect MSG, no backtrace % 
(ERRORSET ERRORVAR2 T NIL)
(PRINT (LIST (QUOTE EMSG!*) EMSG!*))
%  Expect no MSG, but BACKTRACE % 
(ERRORSET ERRORVAR2 NIL T)
(PRINT (LIST (QUOTE EMSG!*) EMSG!*))
% Expect neither MSG nor Backtrace% 
(ERRORSET ERRORVAR2 NIL NIL)
(PRINT (LIST (QUOTE EMSG!*) EMSG!*))

% Test of Rebinding/Unbinding% 

(FLUID (QUOTE (ERRORVAR3 ERRORVAR4)))
(SETQ ERRORVAR3 3)
(SETQ ERRORVAR4 4)

(DE ERRORFN1 (X ERRORVAR3)
  (PROGN (PRINT (LIST (QUOTE ERRORVAR3) ERRORVAR3))
         (SETQ ERRORVAR3 33)
  (PROG (Y ERRORVAR4)
        (PRINT (LIST (QUOTE ERRORVAR3) ERRORVAR3))
        (PRINT (LIST (QUOTE ERRORVAR4) ERRORVAR4))
        (SETQ ERRORVAR3 333)
        (SETQ ERRORVAR4 444)
        (ERROR 555 'Error! Inside! ERRORFN1)
          (RETURN 'Error! Failed))))

% Expect to see 3333 33 44 printed% 
% Followed by ERROR 555 messgae% 
(ERRORSET (QUOTE (ERRORFN1 3333 4444)) T T)
% Expect 3 and 4 as Final values of ERRORVAR3 and ERRORVAR4% 
ERRORVAR3
ERRORVAR4
(!$TEST ERRORVARS
        (EQN ERRORVAR3 3)
        (EQN ERRORVAR4 4)
)
% ----- 3.9 Vectors -----% 
%  Create a few variables that may be vectors % 
(SETQ VECTVAR1 NIL)
(SETQ VECTVAR2 (QUOTE (VECTOR 1 2 3)))
(SETQ VECTVAR3 (QUOTE [1 2 3 4]))

% Expect Type mismatch Error for next 2% 
(GETV VECTVAR1 1)
(GETV VECTVAR2 1)
% Expect 1 2 for next 2% 
(GETV VECTVAR3 0)
(GETV VECTVAR3 1)
% Expect Index error for next 2% 
(GETV VECVAR3 -1)
(GETV VECTVAR3 4)
        

(!$TEST MKVECT
        (VECTORP (SETQ VECTVAR3 (MKVECT 5)))
        (EQN 5 (UPBV VECTVAR3))
        (NULL (GETV VECTVAR3 0))
        (NULL (GETV VECTVAR3 5))
        (EQN 10 (PUTV VECTVAR3 0 10))
        (EQN 10 (GETV VECTVAR3 0))
        (EQN 20 (PUTV VECTVAR3 5 20))
        (EQN 20 (GETV VECTVAR3 5))
)
%  Expect VECTVAR3 to be [ 10 nil nil nil nil 20 ]% 
(PRINT VECTVAR3)

% Expect MKVECT error for index less than 0% 
(MKVECT -1)
% Expect length 1 vector% 
(MKVECT 0)
% Expect type error% 
(MKVECT NIL)
% Expect 2  TYPE  errors% 
(PUTV VECTVAR1 0 1)
(PUTV VECTVAR1 -1 1)

(!$TEST UPBV
        (NULL (UPBV VECTVAR1))
        (EQN (UPBV VECTVAR3 5) 5 )
)
% ----- 3.10 Booleans and Conditionals -----% 
(!$TEST AND
        (EQ T (AND))
        (EQ T (AND T))
        (EQ T (AND T T))
        (EQN 1 (AND T 1))
        (EQ T (AND 1 T))
        (EQ T (AND T T 1 1 T T))
        (NULL (AND NIL))
        (NULL (AND T NIL))
        (NULL (AND NIL T))
        (NULL (AND T T T T NIL T T))
)
% The next should not ERROR, else AND is evaluating all args% 
(AND T T NIL (ERROR 310 'AND! Failed) T)

(!$TEST COND
        (EQN 1 (COND (T 1)))
        (NULL (COND))
        (NULL (COND (NIL 1)))
        (EQN 1 (COND (T 1) (T 2)))
        (EQN 2 (COND (NIL 1) (T 2)))
        (NULL  (COND (NIL 1) (NIL 2)))
)
% Test COND with GO and RETURN% 
(PROG NIL
        (COND (T (GO L1)))
        (ERROR 310 'COND! fell! through)
 L1        (PRINT 'GO! in! cond! worked)
        (COND (T (RETURN (PRINT 'Return! 2))))
        (ERROR 310 'COND! did! not! RETURN)
)
% Certain Extensions to COND might fail% 
%/(COND 1 2)
%/(COND (T))
%/(COND (T 1 2 3))

(!$TEST NOT
        (NULL (NOT T))
        (EQ T (NOT NIL))
)

(!$TEST OR
        (NULL (OR))
        (EQ T (OR T))
        (EQ T (OR T T))
        (EQN T (OR T 1))
        (EQ 1 (OR 1 T))
        (EQ T (OR T T 1 1 T T))
        (NULL (OR NIL))
        (EQ T (OR T NIL))
        (EQ T (OR NIL T))
        (EQ T (OR T T T T NIL T T))
)
% The next should not ERROR, else OR is evaluating all args% 
(OR T NIL NIL (ERROR 310 'OR! Failed) T)

% -----3.11 Arithmetic Functions-----% 
% Setup some ints% 
% Setup some floats% 
(SETQ FZERO (FLOAT 0))
(SETQ FONE (FLOAT 1))
(SETQ FTWO (FLOAT 2))
(SETQ FTHREE (FLOAT 3))
(!$TEST ABS
        (EQN 0 (ABS 0))
        (EQN 1 (ABS 1))
        (EQN 1 (ABS -1))
        (EQN FZERO (ABS FZERO))
        (EQN FONE (ABS FONE))
        (EQN FONE (ABS (MINUS FONE)))
)

(!$TEST ADD1
        (EQN 1 (ADD1 0))
        (EQN 0 (ADD1 -1))
        (EQN 2 (ADD1 1))
        (EQN FONE (ADD1 FZERO))
        (EQN FTWO (ADD1 FONE))
)

(!$TEST DIFFERENCE
        (EQN 0 (DIFFERENCE 1 1))
        (EQN FZERO (DIFFERENCE FONE FONE))
        (EQN FZERO (DIFFERENCE 1 FONE))
        (EQN FZERO (DIFFERENCE FONE 1))
        (EQN 1 (DIFFERENCE 2 1))
        (EQN -1 (DIFFERENCE 1 2))
)

(!$TEST DIVIDE
        (EQUAL (CONS 1 2) (DIVIDE 7 5))
        (EQUAL (CONS -1 -2) (DIVIDE -7 5))
        (EQUAL (CONS -1 2) (DIVIDE 7 -5))
        (EQUAL (CONS 1 -2) (DIVIDE -7 -5))
)
(!$TEST EXPT
        (EQN (EXPT 2 0) 1)
        (EQN (EXPT 2 1) 2)
        (EQN (EXPT 2 2) 4)
        (EQN (EXPT 2 3) 8)
        (EQN (EXPT -2 2) 4)
        (EQN (EXPT -2 3) -8)
)

(!$TEST FIX
        (NUMBERP (FIX FONE))
        (FIXP (FIX FONE))
        (NULL (FLOATP (FIX FONE)))
        (EQN (FIX FONE ) 1)
        (NUMBERP (FIX 1))
        (FIXP (FIX 1))
)

(!$TEST FLOAT
        (NUMBERP (FLOAT 1))
        (FLOATP (FLOAT 1))
        (NULL (FIXP (FLOAT 1)))
        (EQN FONE (FLOAT 1))
)

(!$TEST GREATERP
        (GREATERP 2 1)
        (GREATERP 1 0)
        (GREATERP 0 -1)
        (NULL (GREATERP 2 2))
        (NULL (GREATERP 1 1))
        (NULL (GREATERP 0 0))
        (NULL (GREATERP 0 1))
        (NULL (GREATERP -1 0))
)
(!$TEST LESSP
        (NULL (LESSP 2 1))
        (NULL (LESSP 1 0))
        (NULL (LESSP 0 -1))
        (NULL (LESSP 2 2))
        (NULL (LESSP 1 1))
        (NULL (LESSP 0 0))
        (LESSP 0 1)
        (LESSP -1 0)
)
(!$TEST MAX
        (EQN (MAX 1 2 3) 3)
        (EQN (MAX 3 2 1) 3)
        (EQN 1 (MAX 1 0))
        (EQN 1 (MAX 1))
)
% What is (MAX) ;

(!$TEST MAX2
        (EQN (MAX2 1 2) 2)
        (EQN (MAX2 2 1) 2)
        (EQN 1 (MAX2 1 0))
        (EQN -1 (MAX2 -1 -2))
)
(!$TEST MIN
        (EQN (MIN 1 2 3) 1)
        (EQN (MIN 3 2 1) 1)
        (EQN 0 (MIN 1 0))
        (EQN 1 (MIN 1))
)
% What is (MIN) ;

(!$TEST MIN2
        (EQN (MIN2 1 2) 1)
        (EQN (MIN2 2 1) 1)
        (EQN 0 (MIN2 1 0))
        (EQN 0 (MIN2 0 1))
        (EQN -2 (MIN2 -1 -2))
)
(!$TEST MINUS
        (EQN 0 (MINUS 0))
        (EQN -1 (MINUS 1))
        (MINUSP (MINUS 1))
        (MINUSP -1)
        (LESSP -1 0)
        (EQN 1 (MINUS -1))
)

(!$TEST PLUS
        (EQN 6 (PLUS 1 2 3))
        (EQN 10 (PLUS 1 2 3 4))
        (EQN 0 (PLUS 1 2 3 -6))
        (EQN 3 (PLUS 1 2))
        (EQN 1 (PLUS 1))
)
% What is (PLUS) ;

(!$TEST PLUS2
        (EQN 3 (PLUS2 1 2))
        (EQN 0 (PLUS2 1 -1))
        (EQN 1 (PLUS2 -2 3))
)

(!$TEST QUOTIENT
        (EQN 1 (QUOTIENT 3 3))
        (EQN 1 (QUOTIENT 4 3))
        (EQN 1 (QUOTIENT 5 3))
        (EQN 2 (QUOTIENT 6 3))
        (EQN -1 (QUOTIENT -3 3))
        (EQN -1 (QUOTIENT 3 -3))
        (EQN -1 (QUOTIENT 4 -3))
        (EQN -1 (QUOTIENT -4 3))
)

% Expect 2 ZERO DIVISOR error messages% 
(QUOTIENT 1 0)
(QUOTIENT 0 0)

(!$TEST REMAINDER
        (EQN 0 (REMAINDER 3 3))
        (EQN 1 (REMAINDER 4 3))
        (EQN 2 (REMAINDER 5 3))
        (EQN 0 (REMAINDER 6 3))
        (EQN 0 (REMAINDER -3 3))
        (EQN 0 (REMAINDER 3 -3))
        (EQN -1 (REMAINDER 4 -3))
        (EQN -1 (REMAINDER -4 3))
)

% Expect 2 ZERO DIVISOR  error messages% 
%(REMAINDER 1 0)
%(REMAINDER 0 0)

(!$TEST SUB1
        (EQN 1 (SUB1 2))
        (EQN 0 (SUB1 1))
        (EQN -1 (SUB1 0))
)

(!$TEST TIMES
        (EQN 6 (TIMES 1 2 3))
        (EQN 1 (TIMES 1))
        (EQN 2 (TIMES 1 2))
)
% What is (TIMES) ;

(!$TEST TIMES2
        (EQN 0 (TIMES2 1 0))
        (EQN 0 (TIMES2 0 1))
        (EQN 10 (TIMES2 5 2))
        (EQN -10 (TIMES2 5 -2))
)

% -----3.12 MAP composite functions ------% 

(SETQ LST (QUOTE (1 2 3)))
(DE LISTX (X) (LIST X (QUOTE X)))
(DE PRNTX (X) (PRINT (LISTX X)))

% MAP: Expect 3 lines of output, equivalent to:% 
% ((1 2 3) X)% 
% ((2 3) X)% 
% ((3) X)% 
(!$TEST MAP (NULL (MAP LST (FUNCTION PRNTX))))

% MAPC:          Expect 3 lines of output, equivalent to:% 
% (1 X)% 
% (2 X)% 
% (3 X)% 
(!$TEST MAPC (NULL (MAPC LST (FUNCTION PRNTX))))

% MAPCAN:  Expect 3 lines of output, equivalent to:% 
% (1 X)% 
% (2 X)% 
% (3 X)% 
(!$TEST MAPCAN 
        (EQUAL (MAPCAN LST (FUNCTION PRNTX))
                (QUOTE (1 X 2 X 3 X)))
)

% MAPCAR:  Expect 3 Lines of output, equivalent to:% 
% (1 X)% 
% (2 X)% 
% (3 X)% 
(!$TEST MAPCAR
        (EQUAL        (MAPCAR LST (FUNCTION PRNTX))
                (QUOTE ((1 X) (2 X) (3 X))))
)

% MAPCON:  Expect 3 lines of output, equivalent to:% 
% ((1 2 3) X)% 
% ((2 3) X)% 
% ((3) X)% 
(!$TEST MAPCON
        (EQUAL         (MAPCON LST (FUNCTION PRNTX))
        (QUOTE ((1 2 3) X (2 3) X (3) X)))
)

% MAPLIST: Expect 3 lines of output, equivalent to:% 
% ((1 2 3) X)% 
% ((2 3) X)% 
% ((3) X)% 

(!$TEST MAPLIST
        (EQUAL        (MAPLIST LST (FUNCTION PRNTX))
                (QUOTE (((1 2 3) X) ((2 3) X) ((3) X))))
)

% ----- 3 . 13 Composite Functions -----% 
(SETQ APPVAR1 (QUOTE (1 2 3)))

(!$TEST APPEND
        (NULL (APPEND NIL NIL))
        (EQUAL APPVAR1 (SETQ APPVAR2 (APPEND APPVAR1 NIL)))
        (NULL (EQ APPVAR1 APPVAR2))
        (EQUAL APPVAR1 (SETQ APPVAR2 (APPEND NIL APPVAR1)))
        (EQ APPVAR1 APPVAR2)
        (EQUAL APPVAR1 (APPEND (QUOTE (1)) (QUOTE (2 3))))
        (EQUAL APPVAR1 (APPEND (QUOTE (1 2)) (QUOTE (3))))
)

(SETQ ASSVAR 
   (QUOTE ( ((1 . 1) . ONE) ((2 . 2) . TWO) ((3 . 3) . THREE) ) ) )
(!$TEST ASSOC
        (NULL (ASSOC NIL NIL))
        (NULL (ASSOC 1 NIL))
        (NULL (ASSOC 1 ASSVAR))
        (EQUAL (QUOTE ((1 . 1) . ONE)) (ASSOC (QUOTE (1 . 1)) ASSVAR))
        (EQUAL (QUOTE ((2 . 2) . TWO)) (ASSOC (QUOTE (2 . 2)) ASSVAR))
)
% Expect Error MSG on poor ALIST% 
%(ASSOC (QUOTE (1)) (QUOTE (1 2 3)))

(SETQ DLIST (QUOTE ((AA BB) (EE FF))))

(!$TEST DEFLIST
        (EQUAL (QUOTE (AA EE)) (DEFLIST DLIST (QUOTE DEFLIST)))
        (EQ (QUOTE BB) (GET (QUOTE AA) (QUOTE DEFLIST)))
        (EQ (QUOTE FF) (GET (QUOTE EE) (QUOTE DEFLIST)))
)

(!$TEST DELETE
        (EQUAL (QUOTE ((1 . 1) (2 . 2))) 
               (DELETE (QUOTE (0 . 0)) (QUOTE ((0 . 0) (1 . 1) (2 . 2)))))
        (EQUAL (QUOTE ((0 . 0) (2 . 2))) 
               (DELETE (QUOTE (1 . 1)) (QUOTE ((0 . 0) (1 . 1) (2 . 2)))))
        (EQUAL (QUOTE ((0 . 0) (2 . 2) (1 . 1))) 
               (DELETE (QUOTE (1 . 1)) 
                        (QUOTE ((0 . 0) (1 . 1) (2 . 2) (1 . 1)))))
)

% remove the comments when digit and liter are added.

%(SETQ DIGITLST (QUOTE (!0 !1 !2 !3 !4 !5 !6 !7 !8 !9)))

%(DE TESTEACH (LST FN)
%        (PROG (X)
%         L1     (while t (progn
%            (COND ((NULL (PAIRP LST)) (RETURN T)))
%                (SETQ X (APPLY FN (LIST (CAR LST))))  % Not (FN (CAR LST)) ?
%                (COND ((NULL X) 
%                 (PRINT (LIST '!*!*!*! TESTEACH (CAR LST) 'failed))))
%                (SETQ LST (CDR LST))
%                (GO L1)))))
%
%(!$TEST DIGIT
%        (TESTEACH DIGITLST (FUNCTION DIGIT))
%        (NULL (DIGIT 1))
%        (NULL (DIGIT (QUOTE A)))
%        (NULL (DIGIT '1))
%)

(!$TEST LENGTH
        (EQN 0 (LENGTH (QUOTE A)))
        (EQN 0 (LENGTH 1))
        (EQN 1 (LENGTH (QUOTE (A))))
        (EQN 1 (LENGTH (QUOTE (A . B))))
        (EQN 2 (LENGTH (QUOTE (A B))))
)

%(SETQ UPVAR 
% (QUOTE (A B C D E F G H I J K L M N O P Q R S T U V W X Y Z)))
%(SETQ DNVAR
% (QUOTE (a b c d e f g h i j k l m n o p q r s t u v w x y z)))
%
%(!$TEST LITER
%        (TESTEACH UPVAR (FUNCTION LITER))
%        (TESTEACH DNVAR (FUNCTION LITER))
%        (NULL (LITER 'A))
%        (NULL (LITER 1))
%        (NULL (LITER (QUOTE AA)))
%)

(SETQ MEMBVAR (QUOTE ((1 . 1) ( 2 . 2) (3 . 3))))

(!$TEST MEMBER
        (NULL (MEMBER NIL NIL))
        (NULL (MEMBER NIL MEMBVAR))
        (NULL (MEMBER (QUOTE (4 . 4)) MEMBVAR))
        (EQ (CDR MEMBVAR) (MEMBER (QUOTE (2 . 2)) MEMBVAR))
)

(!$TEST MEMQ
        (NULL (MEMQ NIL NIL))
        (EQ MEMBVAR (MEMQ (CAR MEMBVAR) MEMBVAR))
        (NULL (MEMQ (QUOTE (1 . 1)) MEMBVAR))
        (EQ (CDR MEMBVAR) (MEMQ (CADR MEMBVAR) MEMBVAR))
)


(SETQ NCONCVAR1 (LIST 1 2 3))

(!$TEST NCONC
        (EQUAL (QUOTE ( 1 2 3 4 5)) 
         (SETQ NCONCVAR2 (NCONC NCONCVAR1 (QUOTE ( 4 5)))))
        (EQ NCONCVAR1 NCONCVAR2)
        (EQUAL NCONCVAR1 (QUOTE (1 2 3 4 5)))
)

(!$TEST PAIR
        (EQUAL NIL (PAIR NIL NIL))
        (EQUAL (QUOTE ((1 . ONE) (2 . TWO))) 
            (PAIR (QUOTE (1 2)) (QUOTE (ONE TWO))))
)

% expect 2 PAIR mismatch errors% 

%(PAIR (QUOTE (1)) (QUOTE ( ONE TWO)))
%(PAIR (QUOTE (1)) NIL)

(!$TEST REVERSE
        (NULL (REVERSE NIL))
        (EQUAL (QUOTE (1)) (REVERSE (QUOTE (1))))
        (EQUAL (QUOTE (1 2 3)) (REVERSE (QUOTE (3 2 1))))
        (EQUAL (QUOTE ((1 . 2) (2 . 3) (3 4 5)))
           (REVERSE (QUOTE ((3 4 5) (2 . 3) (1 . 2)))))
)

(DE SASSFN NIL
        (PROG2 (PRINT 'Sassfn! Called) 99))

(SETQ SASSVAR (QUOTE ((1 . ONE) (2 . TWO))))

(!$TEST SASSOC
        (EQN 99 (SASSOC NIL NIL (FUNCTION SASSFN)))
        (EQN 99 (SASSOC NIL SASSVAR (FUNCTION SASSFN)))
        (EQUAL (QUOTE (2 . TWO))
                (SASSOC 2 SASSVAR (FUNCTION SASSFN)))
)

% Expect ERROR for poor alist:
%(SASSOC (QUOTE A) (QUOTE (B (A . 1))) (FUNCTION SASSFN))

% Set up SUBLIS values
(SETQ SUBLVAR1 (QUOTE ((X . 1) ((X . X) . 2))))
(SETQ SUBLVAR2 (QUOTE (X X (X . 1) (X . X) ((X . X)))))
(SETQ SUBLVAR3 (QUOTE (1 1 (1 . 1) 2 (2))))

%(!$TEST SUBLIS
%        (NULL (SUBLIS NIL NIL))
%        (EQN 1 (SUBLIS NIL 1))
%        (EQ SUBLVAR2 (SUBLIS NIL SUBLVAR2))
%        (EQUAL SUBLVAR2 (SUBLIS NIL SUBLVAR2))
%        (EQ SUBLVAR2 (SUBLIS (QUOTE ((Y . 3))) SUBLVAR2))
%% Will fail, but nice opt if no action;
%        (EQUAL SUBLVAR2 (SUBLIS (QUOTE ((Y . 3))) SUBLVAR2))
%        (EQUAL SUBLVAR3 (SUBLIS SUBLVAR1 SUBLVAR2))
%)
%
(!$TEST SUBST
        (NULL (SUBST NIL 1 NIL))
        (EQ (QUOTE A) (SUBST NIL 1 (QUOTE A)))
        (EQN 1 (SUBST  1 2 2))
        (EQUAL (CONS 2 2) (SUBST 2 1 (CONS 1 1)))
        (EQUAL (QUOTE (1 1 (1 . 1) (1 . 1) ((1 . 1))))
                (SUBST 1 (QUOTE X) SUBLVAR2))
)
% ----- 3.14 The Interpreter ----% 

% To be done ;

% ----- 3.15 IO -----% 
% ----- 3.16 The Standard LISP Reader ----% 
% To be done ;

% ----- 4.0 Globals ----% 

% To be done ;

% ----- 5.0 Miscellaneous functions -----% 

% to be done ;

(RDS NIL)

Added perq-pascal-lisp-project/pasn.pas version [4549c76bd3].



























































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
(*%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 %
 %               PASCAL BASED MINI-LISP
 %
 % File:         PASN.RED - Trailer File
 % ChangeDate:   12:26pm  Saturday, 18 July 1981
 % By:           M. L. Griss
 %               Change to add Features for Schlumberger Demo
 %               Add Hooks for CATCH/THROW
 %
 %           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
 %
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%*)


(* pasN.PAS ---- the last file to be appended, close CATCH, do init *)
BEGIN     (*  Body of Catch  *)
IF initphase=0 THEN  (* Kludge to get into scope of CATCH *)
    BEGIN init; initphase := 1; firstp; END
ELSE BEGIN
    idspace[xthrowing].val := nilref;
    catch_stk:=st;                        (* Capture Stack *)
    catch_bstk:=idspace[xbstack].val;     (* Capture Bstack *)
    xeval;
9999:                                 (* Return Point *)
    IF idspace[xthrowing].val <> nilref
    THEN BEGIN
	st:=catch_stk;
	r[2]:=catch_bstk;
	xunbindto; (* return value, old stack *)
	END;
    END
END (* catch *);

BEGIN   (* Top Level *)
    initphase := 0;
    r[1] := 0;
    Xcatch;
    writeln(tty,'halt');break(tty);
end.

Added perq-pascal-lisp-project/pasn.perq version [35e067ff3f].































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
(*%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 %
 %               PASCAL BASED MINI-LISP
 %
 % File:         PASN.RED - Trailer File
 % ChangeDate:   5:39am  Saturday, 26 September 1981
 % By:           M. L. Griss
 %               Add Hooks for CATCH/THROW
 %
 %           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
 %
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%*)


(* pasN.PAS ---- the last file to be appended, close CATCH, do init *)
BEGIN     (*  Body of Catch  *)
IF initphase=0 THEN  (* Kludge to get into scope of CATCH *)
    BEGIN init; initphase := 1; firstp; END
ELSE BEGIN
    initphase := initphase + 1;
    idspace[xthrowing].val := nilref;
    catch_stk:=st;                        (* Capture Stack *)
    catch_bstk:=idspace[xbstack].val;     (* Capture Bstack *)
    xeval;
    initphase := initphase - 1;
   (* Return Point *)
    IF idspace[xthrowing].val <> nilref
    THEN BEGIN
	st:=catch_stk;
	r[2]:=catch_bstk;
	xunbindto; (* return value, old stack *)
	END;
    END
END (* catch *);

BEGIN   (* Top Level *)
    initphase := 0;
    r[1] := nilref;
    Xcatch;
      writeln('halt after top catch');
 exit(pas0);
end.

Added perq-pascal-lisp-project/pasn.pre version [7dcab7157e].

































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
#adptwv      (* Pre-process with filter *)
(*
 
                PASCAL BASED MINI-LISP
 
  File:         PASN.RED - Trailer File
  ChangeDate:   5:39am  Saturday, 26 September 1981
  By:           M. L. Griss
                Add Hooks for CATCH/THROW
 
            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
 
*)


(* pasN.PAS ---- the last file to be appended, close CATCH, do init *)
BEGIN     (*  Body of Catch  *)
IF initphase=0 THEN  (* Kludge to get into scope of CATCH *)
    BEGIN init; initphase := 1; firstp; END
ELSE BEGIN
#p  initphase:=initphase+1;               (* ??? *)
    idspace[xthrowing].val := nilref;
    catch_stk:=st;                        (* Capture Stack *)
    catch_bstk:=idspace[xbstack].val;     (* Capture Bstack *)
    xeval;
#p    initphase:=initphase-1;            (* ??? *)
   (* Return Point *)
#adv 9999:
    IF idspace[xthrowing].val <> nilref
    THEN BEGIN
        st:=catch_stk;
        r[2]:=catch_bstk;
        xunbindto; (* return value, old stack *)
        END;
    END
END (* catch *);

BEGIN   (* Top Level *)
    initphase := 0;
    r[1] := nilref;
    Xcatch;
#d  break(tty);
end.

Added perq-pascal-lisp-project/pl20.prc version [ff1955f149].





































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
PASCAL/UTAH FROM  31-MAR-79     PROC/FUNC LINE NUMBER REPORT OF PL20  .PAS ON 14-MAR-82  AT 16:45:36  

PROC/FUNC   HEAD BEGIN   END

        XTHROW       236   237   240
        TAG_OF       250   252   254
        INFO_OF      257   259   264
        XNULL        267   268   271
                    MARK         288   289   297
                GC_INT       283   299   321
            MKFIXINT     280   323   343
        MKITEM       274   347   363
        MKERR        366   367   369
        SET_INFO     372   373   375
        SET_TAG      378   379   381
        MKIDENT      384   386   388
        MKINT        391   392   394
        MKPAIR       397   398   400
        INT_VAL      403   408   415
        ALLOC        425   426   436
        DEALLOC      438   439   444
        ALLOC1       448   449   449
        DEALLOC1     451   452   452
        ALLOC2       454   455   455
        DEALLOC2     457   458   458
        ALLOC3       460   461   461
        DEALLOC3     463   464   464
        LOAD         473   474   478
        STORE        480   481   483
        LOAD10       486   487   489
        STORE10      491   492   494
        STORENIL     496   497   499
        NMHASH       508   513   522
        EQSTR        524   525   532
        NMLOOKUP     534   540   567
        PUTNM        569   575   587
        XFASTSTAT    596   598   607
            PUSHREF      620   622   639
            MARK         641   646   655
        XGCOLLECT    610   657   709
        XCONS        719   722   739
        XNCONS       741   742   744
        XXCONS       746   747   751
        XCAR         763   764   769
        XCDR         771   772   777
        XRPLACA      779   780   785
        XRPLACD      787   788   793
        ANYCAR       796   797   802
        ANYCDR       804   805   810
            IS_INT       825   828   844
        COMPRESS     819   846   884
            ID_EXPLODE   888   889   898
            INT_EXPLOD   900   903   926
        EXPLODE      886   928   939
            KICK         944   945   953
        GENSYM       941   955   970
        XOPEN        979   985  1023
        XCLOSE      1025  1026  1034
        XRDS        1036  1039  1043
        XWRS        1045  1048  1052
        XTERPRI     1054  1055  1060
        INT_FIELD   1062  1065  1075
        XWRITEINT   1077  1078  1083
        XWRITECHAR  1085  1086  1091
        XWRTOK      1093  1096  1142
        RDCHNL      1145  1146  1171
        EOFCHNL     1174  1175  1181
            DIGIT       1201  1202  1204
            ESCALPHA    1207  1210  1228
            ALPHANUM    1230  1233  1238
            WHITESP     1240  1241  1245
        XRDTOK      1190  1247  1351
            INIT1       1372  1373  1455
            INIT2       1458  1459  1505
        INIT        1360  1528  1531
        XADD1       1540  1543  1546
        XDIFFERENC  1548  1551  1555
        XDIVIDE     1557  1561  1569
        XGREATERP   1571  1574  1582
        XLESSP      1584  1587  1595
        XMINUS      1597  1600  1603
        XPLUS2      1605  1608  1612
        XQUOTIENT   1614  1617  1622
        XREMAINDER  1624  1627  1632
        XTIMES2     1634  1637  1641
        XXAPPLY     1656  1662  1682
        PAS11       1698  1699  1708
        PAS12       1711  1712  1721
        PAS13       1724  1725  1734
        PAS14       1737  1738  1747
        PAS15       1750  1751  1762
        PAS16       1765  1766  1777
        PAS17       1780  1781  1792
        PAS18       1795  1796  1807
        PAS19       1810  1811  1822
        PAS110      1825  1826  1837
        PAS111      1840  1841  1852
        PAS112      1855  1856  1867
        PAS113      1870  1871  1882
        PAS114      1885  1886  1897
        PAS115      1900  1901  1912
        PAS116      1915  1916  1927
        PAS117      1930  1931  1942
        PAS118      1945  1946  1957
        PAS119      1960  1961  1972
        PAS120      1975  1976  1987
        PAS121      1990  1991  2001
        PAS122      2004  2005  2015
        PAS123      2018  2019  2029
        PAS124      2032  2033  2043
        PAS125      2046  2047  2057
        PAS126      2060  2061  2071
        PAS127      2074  2075  2085
        PAS128      2088  2089  2099
        PAS129      2104  2110  2170
        PAS130      2173  2178  2222
        PAS131      2225  2226  2236
        PAS132      2239  2243  2266
        XREAD       2271  2278  2351
        PAS133      2354  2363  2465
        PAS21       2478  2482  2498
        PAS23       2503  2504  2512
        XCODEP      2515  2519  2535
        PAS26       2542  2545  2565
        PAS27       2568  2569  2575
        PAS28       2578  2579  2595
        PAS29       2598  2599  2619
        PAS210      2622  2623  2647
        PAS211      2650  2651  2679
        PAS212      2682  2683  2689
        PAS213      2692  2696  2730
        PAS214      2735  2740  2773
        PAS216      2780  2786  2842
        PAS218      2849  2854  2900
        PAS220      2907  2912  2968
        PAS221      2973  2978  3032
        PAS222      3037  3042  3065
        PAS223      3070  3076  3120
        PAS219      3123  3129  3185
        PAS225      3192  3196  3242
        PAS227      3249  3254  3296
        PAS228      3301  3306  3341
        PAS229      3346  3352  3400
        PAS230      3403  3407  3437
        PAS224      3440  3446  3514
        PAS231      3517  3518  3526
        PAS232      3531  3535  3555
        PAS233      3558  3559  3575
        PAS234      3578  3579  3595
        PAS235      3598  3601  3627
        PAS237      3634  3638  3668
        PAS236      3671  3676  3722
        PAS239      3729  3733  3763
        PAS238      3766  3770  3816
        PAS22       3819  3823  3839
        PAS240      3842  3846  3866
        PAS25       3869  3870  3878
        PAS241      3881  3882  3888
        PAS242      3891  3892  3898
        PAS243      3901  3902  3908
        PAS244      3911  3912  3918
        PAS245      3921  3922  3928
        PAS246      3931  3932  3938
        PAS247      3941  3942  3966
        PAS248      3969  3972  3988
        PAS226      3991  3997  4043
        PAS215      4046  4047  4077
        PAS249      4080  4085  4133
        PAS251      4138  4139  4145
        PAS253      4150  4154  4178
        PAS254      4181  4182  4190
        PAS255      4193  4194  4202
        PAS256      4205  4206  4214
        PAS24       4217  4221  4237
        PAS257      4242  4247  4296
        PAS258      4299  4300  4304
        PAS259      4307  4308  4312
        PAS261      4317  4318  4328
        PAS262      4331  4332  4342
        PAS263      4345  4346  4356
        PAS264      4359  4360  4370
        PAS265      4373  4377  4401
        PAS266      4404  4408  4432
        PAS267      4435  4436  4442
        PAS260      4445  4449  4481
        PAS250      4484  4488  4505
        PAS268      4508  4512  4528
        PAS252      4531  4535  4558
        PAS269      4561  4566  4606
        PAS270      4609  4610  4616
        PAS271      4619  4620  4626
        XPRINT      4629  4630  4644
        PAS272      4647  4648  4662
        PAS273      4665  4666  4694
        PAS274      4697  4698  4724
        PAS275      4727  4730  4766
        PAS276      4769  4773  4803
        XUNBINDTO   4806  4810  4838
        PAS279      4845  4849  4898
        PAS277      4903  4908  4948
        PAS280      4951  4955  4981
        PAS31       4994  4999  5043
        PAS32       5046  5047  5065
        PAS33       5068  5073  5125
        PAS34       5128  5136  5253
        PAS35       5256  5259  5289
        PAS36       5294  5298  5332
        PAS37       5335  5336  5358
        PAS38       5361  5362  5384
        PAS39       5387  5388  5410
        PAS310      5413  5414  5436
        XEVAL       5443  5457  5606
        PAS312      5609  5610  5628
        PAS217      5631  5635  5659
        PAS311      5662  5666  5698
        PAS313      5701  5702  5708
        PAS314      5711  5712  5718
        PAS278      5721  5725  5753
        PAS315      5756  5757  5771
        PAS316      5774  5779  5853
        PAS317      5856  5860  5888
        PAS319      5893  5899  6021
        PAS320      6024  6029  6063
        PAS321      6066  6071  6115
        PAS322      6118  6126  6194
        PAS323      6197  6202  6236
        PAS318      6239  6243  6271
        PAS324      6274  6278  6306
        PAS325      6313  6317  6357
        PAS327      6362  6366  6404
        PAS328      6409  6413  6453
        PAS329      6458  6462  6500
        PAS326      6503  6509  6551
        PAS330      6554  6555  6561
        PAS331      6564  6565  6569
        PAS332      6574  6578  6608
        PAS333      6611  6612  6618
        PAS334      6621  6622  6628
        PAS335      6631  6632  6638
        PAS336      6641  6642  6648
        PAS337      6651  6652  6656
        PAS338      6659  6660  6666
        PAS339      6669  6673  6697
        PAS340      6700  6701  6709
        PAS341      6712  6713  6719
        PAS342      6722  6723  6729
        PAS343      6732  6733  6739
        PAS344      6742  6743  6749
        PAS345      6752  6753  6759
        PAS346      6762  6763  6769
        PAS347      6772  6773  6779
        PAS348      6782  6783  6789
        PAS349      6792  6796  6818
        PAS350      6821  6824  6860
        FIRSTP      6863  6871  7007
        EXECUTE     7008  7009  7417
    XCATCH       219  7439  7456
PAS0          31  7458  7463

Added perq-pascal-lisp-project/poltok.red version [0daa262c75].

































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
LISP$
% Simple TOKEN scanner to Debug POLY. RED;
% Griss and Morrison

GLOBAL '(CURCHARTYPE!* CURCHAR!* TOK!*);

SYMBOLIC PROCEDURE CLEARTOKEN;              %. Clear token scanner
 <<CURCHARTYPE!* := 'WHITE; CURCHAR!* := '! >>;

SYMBOLIC PROCEDURE NTOKEN;		%. get next token
BEGIN SCALAR TOK;
  WHILE CURCHARTYPE!* MEMQ '(WHITE COMMENT) DO
    IF CURCHARTYPE!* EQ 'WHITE THEN
      READCHAR()
    ELSE << % Skip the comment
      REPEAT
	READCHAR()
      UNTIL CURCHAR!* MEMQ COMMENTEND!*;
    READCHAR() >>;
  IF CURCHARTYPE!* EQ 'DIGIT THEN <<
    WHILE CURCHARTYPE!* EQ 'DIGIT DO <<
      TOK := CURCHAR!* . TOK;
      READCHAR() >>;
    TOK!* := COMPRESS REVERSIP TOK >>
  ELSE IF CURCHARTYPE!* MEMQ '(LETTER ESCAPE) THEN <<
    WHILE CURCHARTYPE!* MEMQ '(LETTER ESCAPE) DO <<
      IF CURCHARTYPE!* EQ 'ESCAPE THEN <<
	TOK := '!! . TOK;
	READCHAR() >>;
      TOK := CURCHAR!* . TOK;
      READCHAR() >>;
    TOK!* := INTERN COMPRESS REVERSIP TOK >>
  ELSE IF CURCHARTYPE!* EQ 'DELIMITER THEN <<
    TOK!* := CURCHAR!*;
    READCHAR();TOK!* >>
  ELSE IF CURCHARTYPE!* EQ 'TERMINATOR THEN <<
     TOK!* := CURCHAR!*;    CLEARTOKEN();   TOK!*>>
  ELSE
    ERROR(1010,
	  LIST( "Illegal character `",COMPRESS LIST('!!,CURCHAR!*),
			          "' in input stream -- NTOKEN") );
END NTOKEN;

SYMBOLIC PROCEDURE READCHAR;	%. Get next char and classify
<< CURCHAR!* := READCH();
   CURCHARTYPE!* := GET(CURCHAR!*,'CHARACTERTYPE) >>;

SYMBOLIC PROCEDURE INITTOKEN;	%. Initialise TOKEN scan
 BEGIN
DEFLIST('(
 (A LETTER)
 (B LETTER)
 (C LETTER)
 (D LETTER)
 (E LETTER)
 (F LETTER)
 (G LETTER)
 (H LETTER)
 (I LETTER)
 (J LETTER)
 (K LETTER)
 (L LETTER)
 (M LETTER)
 (N LETTER)
 (O LETTER)
 (P LETTER)
 (Q LETTER)
 (R LETTER)
 (S LETTER)
 (T LETTER)
 (U LETTER)
 (V LETTER)
 (W LETTER)
 (X LETTER)
 (Y LETTER)
 (Z LETTER)
 (a LETTER)
 (b LETTER)
 (c LETTER)
 (d LETTER)
 (e LETTER)
 (f LETTER)
 (g LETTER)
 (h LETTER)
 (i LETTER)
 (j LETTER)
 (k LETTER)
 (l LETTER)
 (m LETTER)
 (n LETTER)
 (o LETTER)
 (p LETTER)
 (q LETTER)
 (r LETTER)
 (s LETTER)
 (t LETTER)
 (u LETTER)
 (v LETTER)
 (w LETTER)
 (x LETTER)
 (y LETTER)
 (z LETTER)
 (!_ LETTER)
 (!. LETTER)
 (!0 DIGIT)
 (!1 DIGIT)
 (!2 DIGIT)
 (!3 DIGIT)
 (!4 DIGIT)
 (!5 DIGIT)
 (!6 DIGIT)
 (!7 DIGIT)
 (!8 DIGIT)
 (!9 DIGIT)
 (!+ DELIMITER)
 (!- DELIMITER)
 (!* DELIMITER)
 (!/ DELIMITER)
 (!^ DELIMITER)
 (!' DELIMITER)
 (!( DELIMITER)
 (!) DELIMITER)
 (!, DELIMITER)
 (!; TERMINATOR)
 (!! ESCAPE)
 (!  WHITE)     % Blank
 (!	 WHITE)	% Tab
 (!
 WHITE)	% Carriage Return
 (!
 WHITE)	% Line Feed
 (! WHITE)	% Form Feed
 (!% COMMENT)
   ), 'CHARACTERTYPE);
	PUT(!$EOL!$,'CHARACTERTYPE,'WHITE);
	COMMENTEND!* := LIST !$EOL!$;
	CLEARTOKEN();
END;

INITTOKEN();

SYMBOLIC PROCEDURE XAPPLY(FN,ARGS);     %. Interface for PLISP
   APPLY(FN,ARGS)$

END$

Added perq-pascal-lisp-project/poly.ini version [11eb9a5528].

cannot compute difference between binary files

Added perq-pascal-lisp-project/poly.red version [63bc0160db].

















































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
OFF ECHO,RAISE$
LISP;

% Simple POLY, RAT AND ALG system, based on POLY by Fitch and Marti. 
% Modifed by GRISS and GALWAY
% September 1980. 
% Further modified by MORRISON
% October 1980.
% Parser modified by OTTENHEIMER
% February 1981, to be left associative March 1981.
% Current bug: print routines print as if right associative.
% MORRISON again, March 1981.
% Parses INFIX expressions to PREFIX, then SIMPlifies and PRINTs
% Handles also PREFIX expressions

% RUNNING: After loading POLY.RED, run function ALGG();
%   This accepts a sequence of expressions:
%	 <exp> ;	 (Semicolon terminator)
%	 <exp> ::= <term> [+ <exp>  | - <exp>]
%	 <term> ::= <primary> [* <term> | / <term>]
%	 <primary> ::= <primary0> [^ <primary0> | ' <primary0> ]
%		 ^ is exponentiation, ' is derivative
%	 <primary0> ::= <number> | <variable> | ( <exp> )

% PREFIX Format:	<number> | <id> | (op arg1 arg2)
%		+ -> PLUS2
%		- -> DIFFERENCE (or MINUS)
%		* -> TIMES2
%		/ -> QUOTIENT
%		^ -> EXPT
%		' -> DIFF

% Canonical Formats: Polynomial: integer | (term . polynomial)
%                    term      : (power . polynomial)
%                    power     : (variable . integer)
%                    Rational  : (polynomial .  polynomial)

%******************** Selectors and Constructors **********************

SYMBOLIC SMACRO PROCEDURE RATNUM X; % parts of Rational
 CAR X;

SYMBOLIC SMACRO PROCEDURE RATDEN X;
 CDR X;

SYMBOLIC SMACRO PROCEDURE MKRAT(X,Y);
  CONS(X,Y);

SYMBOLIC SMACRO PROCEDURE POLTRM X;	% parts of Poly
 CAR X;

SYMBOLIC SMACRO PROCEDURE POLRED X;
 CDR X;

SYMBOLIC SMACRO PROCEDURE MKPOLY(X,Y);
 CONS(X,Y);

SYMBOLIC SMACRO PROCEDURE TRMPWR X;	% parts of TERM
 CAR X;

SYMBOLIC SMACRO PROCEDURE TRMCOEF X;
 CDR X;

SYMBOLIC SMACRO PROCEDURE MKTERM(X,Y);
 CONS(X,Y);

SYMBOLIC SMACRO PROCEDURE PWRVAR X;	% parts of Poly
 CAR X;

SYMBOLIC SMACRO PROCEDURE PWREXPT X;
 CDR X;

SYMBOLIC SMACRO PROCEDURE MKPWR(X,Y);
 CONS(X,Y);

SYMBOLIC SMACRO PROCEDURE POLVAR X;
 PWRVAR TRMPWR POLTRM X;

SYMBOLIC SMACRO PROCEDURE POLEXPT X;
 PWREXPT TRMPWR POLTRM X;

SYMBOLIC SMACRO PROCEDURE POLCOEF X;
  TRMCOEF POLTRM X;

%*********************** Utility Routines *****************************

SYMBOLIC PROCEDURE VARP X;
 IDP X OR (PAIRP X AND IDP CAR X);


%*********************** Entry Point **********************************

GLOBAL '(!*RBACKTRACE !*RECHO REXPRESSION!* !*RMESSAGE);

!*RECHO := !*RMESSAGE := T;

SYMBOLIC PROCEDURE ALGG();	%. Main LOOP, end with QUIT OR Q
BEGIN SCALAR VVV;
      ALGINIT();
      CLEARTOKEN();		% Initialize scanner
LOOP: VVV := ERRORSET('(RPARSE),T,!*RBACKTRACE);
      IF ATOM VVV THEN		% What about resetting the Scanner?
	<<PRINT LIST('ALGG, 'error, VVV); CLEARTOKEN();GO TO LOOP>>;
      REXPRESSION!* := CAR VVV;
      IF !*RECHO THEN PRINT REXPRESSION!*;
      IF REXPRESSION!* EQ 'QUIT THEN <<
	PRINT 'QUITTING;
	RETURN >>;
      ERRORSET('(PREPRINT (PRESIMP REXPRESSION!*)),T,!*RBACKTRACE);
  GO TO LOOP
END ALGG;

SYMBOLIC PROCEDURE ALGINIT();   %. Called to INIT tables
 BEGIN  
	INITTOKEN();
	PUT('TIMES2,'RSIMP,'R!*);	%. Simplifier Tables
	PUT('PLUS2,'RSIMP,'R!+);
	PUT('DIFFERENCE,'RSIMP,'R!-);
	PUT('QUOTIENT,'RSIMP,'R!/);
	PUT('EXPT,'RSIMP,'R!^);
	PUT('DIFF,'RSIMP,'R!');
	PUT('MINUS,'RSIMP,'R!.NEG);
	PUT('!+,'REXP,'PLUS2);	 % Use corresponding 'R!xx in EVAL mode
	PUT('!-,'REXP,'DIFFERENCE);
	PUT('!*,'RTERM,'TIMES2);;
	PUT('!/,'RTERM,'QUOTIENT);
	PUT('!^,'RPRIMARY,'EXPT);
	PUT('!','RPRIMARY,'DIFF);
	PUT('PLUS2,'PRINOP,'PLUSPRIN);	%. Output funs
	PUT('DIFFERENCE,'PRINOP,'DIFFERENCEPRIN);
	PUT('TIMES2,'PRINOP,'TIMESPRIN);
	PUT('QUOTIENT,'PRINOP,'QUOTPRIN);
	PUT('EXPT,'PRINOP,'EXPPRIN);
 END;

SYMBOLIC PROCEDURE RSIMP X;	 %. Simplify Prefix Form to Canonical
 IF ATOM X THEN RCREATE X
  ELSE BEGIN SCALAR Y,OP;
   OP:=CAR X; 
   IF (Y:=GET(OP,'RSIMP)) THEN RETURN XAPPLY(Y,RSIMPL CDR X);
  Y:=PRESIMP X;      % As "variable" ? 
  IF ATOM Y OR NOT(X=Y) THEN RETURN RSIMP Y;
  RETURN RCREATE Y;
 END;

SYMBOLIC PROCEDURE RSIMPL X;	%. Simplify argument list
 IF NULL X THEN NIL  ELSE RSIMP(CAR X) . RSIMPL CDR X;

SYMBOLIC PROCEDURE PRESIMP X;	 %. Simplify Prefix Form to PREFIX
 IF ATOM X THEN X
  ELSE BEGIN SCALAR Y,OP;
   OP:=CAR X; 
   IF (Y:=GET(OP,'RSIMP)) THEN RETURN RAT2PRE XAPPLY(Y,RSIMPL CDR X);
   X:=PRESIMPL CDR X;
   IF (Y:=GET(OP,'PRESIMP)) THEN RETURN XAPPLY(Y,X);
   RETURN (OP . X);
 END;

SYMBOLIC PROCEDURE PRESIMPL X;	%. Simplify argument list
 IF NULL X THEN NIL  ELSE PRESIMP(CAR X) . PRESIMPL CDR X;

%**************** Simplification Routines for Rationals ***************

SYMBOLIC PROCEDURE R!+(A,B);	%. RAT addition
    IF RATDEN A = RATNUM B THEN
	MAKERAT(P!+(RATNUM A,RATNUM B),CDR A)
     ELSE
	MAKERAT(P!+(P!*(RATNUM A,RATDEN B),
		     P!*(RATDEN A,RATNUM B)),
		P!*(RATDEN A,RATDEN B));

SYMBOLIC PROCEDURE R!-(A,B);	%. RAT subtraction
    R!+(A,R!.NEG B);

SYMBOLIC PROCEDURE R!.NEG A;	%. RAT negation
    MKRAT(P!.NEG RATNUM A,RATDEN A);

SYMBOLIC PROCEDURE R!*(A,B);	%. RAT multiplication
    BEGIN SCALAR X,Y;
	X:=MAKERAT(RATNUM A,RATDEN B);
	Y:=MAKERAT(RATNUM B,RATDEN A);
	IF RATNUM X=0 OR RATNUM Y=0 THEN RETURN 0 . 1;
	RETURN MKRAT(P!*(RATNUM X,RATNUM Y),
		    P!*(RATDEN X,RATDEN Y))
END;

SYMBOLIC PROCEDURE R!.RECIP A;	%. RAT inverse
    IF RATNUM A=0 THEN ERROR(777,'(ZERO DIVISOR))
    ELSE MKRAT(RATDEN A,RATNUM A);

SYMBOLIC PROCEDURE R!/(A,B); 	%. RAT division
   R!*(A,R!.RECIP B);

SYMBOLIC PROCEDURE R!.LVAR A;	%. Leading VARIABLE of RATIONAL
 BEGIN SCALAR P;
	P:=RATNUM A;
	IF NUMBERP P THEN RETURN ERROR(99,'(non structured polynomial));
	P:=POLVAR P;
	RETURN P;
 END;

SYMBOLIC PROCEDURE R!'(A,X);	%. RAT derivative
 <<X:=R!.LVAR X;
   IF RATDEN A=1 THEN MKRAT(PDIFF(RATNUM A,X),1)
    ELSE R!-(MAKERAT(PDIFF(RATNUM A,X),RATDEN A),
	     MAKERAT(P!*(RATNUM A,PDIFF(RATDEN A,X)),
		     P!*(RATDEN A,RATDEN A) ) ) >>;

SYMBOLIC PROCEDURE RCREATE X;		%. RAT create
    IF NUMBERP X THEN X . 1
     ELSE IF VARP X THEN (PCREATE X) . 1
     ELSE ERROR(100,LIST(X, '(non kernel)));

SYMBOLIC PROCEDURE MAKERAT(A,B);
IF A=B THEN MKRAT(1,1)
 ELSE IF A=0 THEN 0 . 1
 ELSE IF B=0 THEN ERROR(777,'(ZERO DIVISOR))
 ELSE IF NUMBERP A AND NUMBERP B THEN 
	BEGIN SCALAR GG;
	    GG:=NUMGCD(A,B);
            IF B<0 THEN <<B:=-B; A := -A>>;
    	    RETURN MKRAT(A/GG,B/GG)
	END
 ELSE BEGIN SCALAR GG,NN;
	GG:=PGCD(A,B);
	IF GG=1 THEN RETURN MKRAT(A,B);
	NN:=GG;
LL:	IF NUMBERP NN THEN NN:=GCDPT(GG,NN)
	 ELSE << NN:=POLCOEF GG; GOTO LL >>;
	GG:=CAR PDIVIDE(GG,NN);
	RETURN MKRAT(DIVIDEOUT(A,GG),DIVIDEOUT(B,GG))
END;

SYMBOLIC PROCEDURE R!^(A,N);		%. RAT Expt
 BEGIN  SCALAR AA;
   N:=RATNUM N;
   IF NOT NUMBERP N THEN RETURN ERROR(777,'(Non numeric exponent))
      ELSE IF N=0 THEN RETURN RCREATE 1;
     IF N<0 THEN <<A:=R!.RECIP A; N:=-N>>;
	AA:=1 . 1;
	FOR I:=1:N DO AA:=R!*(AA,A);
	RETURN AA
  END;

%**************** Simplification Routines for Polynomials *************

SYMBOLIC PROCEDURE P1!+(A, B);	% Fix for UCSD pascal to cut down proc size
    BEGIN SCALAR AA,BB;
    AA:=P!+(POLCOEF A,POLCOEF B);
    IF AA=0 THEN RETURN P!+(POLRED A,POLRED B);
    AA:=MKPOLY(TRMPWR POLTRM A,AA);
    AA:=ZCONS AA; BB:=P!+(POLRED A,POLRED B);
    RETURN P!+(AA,BB) 
    END P1!+;

SYMBOLIC PROCEDURE P!+(A,B);	%. POL addition
    IF A=0 THEN B  ELSE IF B=0 THEN A  ELSE
    IF NUMBERP A AND NUMBERP B THEN PLUS2(A,B)
     ELSE IF NUMBERP A THEN MKPOLY(POLTRM B,P!+(A,POLRED B))
     ELSE IF NUMBERP B THEN MKPOLY(POLTRM A,P!+(B,POLRED A))
     ELSE BEGIN SCALAR ORD;
	ORD:=PORDERP(POLVAR A,POLVAR B);
	IF ORD=1 THEN RETURN MKPOLY(POLTRM A,P!+(POLRED A,B));
	IF ORD=-1 THEN RETURN MKPOLY(POLTRM B,P!+(POLRED B,A));
	IF POLEXPT A=POLEXPT B THEN RETURN P1!+(A, B);
	IF POLEXPT A>POLEXPT B THEN RETURN
		MKPOLY(POLTRM A,P!+(POLRED A,B));
	RETURN MKPOLY(POLTRM B,P!+(POLRED B,A))
    END;

SYMBOLIC PROCEDURE PORDERP(A,B);	%. POL variable ordering
  IF A EQ B THEN 0
	 ELSE IF ORDERP(A,B) THEN 1  ELSE -1;

SYMBOLIC PROCEDURE P!*(A,B);		%. POL multiply
    IF NUMBERP A THEN
        IF A=0 THEN 0
	 ELSE IF NUMBERP B THEN TIMES2(A,B)
	 ELSE CONS(CONS(CAAR B,PNTIMES(CDAR B,A)),
		  PNTIMES(CDR B,A))
     ELSE IF NUMBERP B THEN  PNTIMES(A,B)
     ELSE P!+(PTTIMES(CAR A,B),P!*(CDR A,B));

SYMBOLIC PROCEDURE PTTIMES(TT,A);	%. POL term mult
    IF NUMBERP A THEN
	IF A=0 THEN 0  ELSE
	ZCONS CONS(CAR TT,PNTIMES(CDR TT,A))
     ELSE P!+(TTTIMES(TT,CAR A),PTTIMES(TT,CDR A));

SYMBOLIC PROCEDURE PNTIMES(A,N);	%. POL numeric coef mult
    IF N=0 THEN 0
     ELSE IF NUMBERP A THEN TIMES2(A,N)
     ELSE CONS(CONS(CAAR A,PNTIMES(CDAR A,N)),PNTIMES(CDR A,N));

SYMBOLIC PROCEDURE TTTIMES(TA,TB);	%. TERM Mult
    BEGIN SCALAR ORD;
	ORD:=PORDERP(CAAR TA,CAAR TB);
	RETURN IF ORD=0 THEN
		ZCONS(CONS(CONS(CAAR TA,PLUS2(CDAR TA,CDAR TB)),
			P!*(CDR TA,CDR TB)))
	 ELSE IF ORD=1 THEN
		ZCONS(CONS(CAR TA,P!*(ZCONS TB,CDR TA)))
	 ELSE    ZCONS(CONS(CAR TB,P!*(ZCONS TA,CDR TB)))
END;

SYMBOLIC PROCEDURE ZCONS A; 		%. Make single term POL
  CONS(A,0);

SYMBOLIC PROCEDURE PCREATE1(X);          %. Create POLY from Variable/KERNEL
	ZCONS(CONS(CONS(X,1),1));

SYMBOLIC PROCEDURE PCREATE X;
 IF IDP X THEN PCREATE1 X
  ELSE IF PAIRP X AND IDP CAR X THEN PCREATE1 MKKERNEL X
  ELSE ERROR(1000,LIST(X, '(bad kernel)));

SYMBOLIC PROCEDURE PGCD(A,B);		%. POL Gcd
% A and B must be primitive.
IF A=1 OR B=1 THEN 1  ELSE
IF NUMBERP A AND NUMBERP B THEN NUMGCD(A,B)
 ELSE IF NUMBERP A THEN GCDPT(B,A)
 ELSE IF NUMBERP B THEN GCDPT(A,B)
 ELSE BEGIN SCALAR ORD;
	ORD:=PORDERP(CAAAR A,CAAAR B);
	IF ORD=0 THEN RETURN GCDPP(A,B);
	IF ORD>0 THEN RETURN GCDPT(A,B);
	RETURN GCDPT(B,A)
END;

SYMBOLIC PROCEDURE NUMGCD(A,B);		%. Numeric GCD
	IF A=0 THEN ABS B
	 ELSE NUMGCD(REMAINDER(B,A),A);

SYMBOLIC PROCEDURE GCDPT(A,B);		%. POL GCD, non-equal vars
IF NUMBERP A THEN IF NUMBERP B THEN NUMGCD(A,B)  ELSE
	GCDPT(B,A)  ELSE
BEGIN SCALAR ANS,ANS1;
	ANS:=PGCD(CDAR A,B);
	A:=CDR A;
	WHILE NOT NUMBERP A DO <<
	    ANS1:=PGCD(CDAR A,B);
	    ANS:=PGCD(ANS,ANS1);
	    A:=CDR A;
	    IF ANS=1 THEN RETURN ANS >>;
	RETURN IF A=0 THEN ANS  ELSE GCDPT(ANS,A)
END;

SYMBOLIC PROCEDURE GCDPP(A,B);		%. POL GCD, equal vars
BEGIN SCALAR TT,PA,ALPHA,PREVALPHA;
	IF POLEXPT B>POLEXPT A THEN <<
	  TT := A;
	  A := B;
	  B := TT >>;
	ALPHA := 1;
LOOP:	PREVALPHA := ALPHA;
	ALPHA := POLCOEF B;
	PA := POLEXPT A - POLEXPT B;
	IF PA<0 THEN <<
          PRINT A;
	  PRINT B;
	  PRINT PA;
	  ERROR(999,'(WRONG)) >>;
	WHILE NOT (PA=0) DO <<
	  PA := PA-1;
	  ALPHA := P!*(POLCOEF B,ALPHA) >>;
	A := P!*(A,ALPHA);	% to ensure no fractions;
	TT := CDR PDIVIDE(A,B);	% quotient and remainder of polynomials;
	IF TT=0 THEN
	  RETURN B;	% which is the GCD;
	A := B;
	B := PDIVIDE(TT,PREVALPHA);
	IF NOT(CDR B=0) THEN
	  ERROR(12,'(REDUCED PRS FAILS));
	B := CAR B;
	IF NUMBERP B OR NOT (POLVAR A EQ POLVAR B) THEN RETURN 1;
                % Lost leading VAR we started with. /MLG
	GO TO LOOP
END;

SYMBOLIC PROCEDURE DIVIDEOUT(A,B);	%. POL exact division
	CAR PDIVIDE(A,B);
	    
SYMBOLIC PROCEDURE PDIVIDE(A,B);	%. POL (quotient.remainder)
    IF NUMBERP A THEN
	IF NUMBERP B THEN DIVIDE(A,B)
	 ELSE CONS(0,A)
    ELSE IF NUMBERP B THEN
	BEGIN SCALAR SS,TT;
	SS:=PDIVIDE(CDR A,B);
	TT:=PDIVIDE(CDAR A,B);
	RETURN CONS(
		P!+(P!*(ZCONS CONS(CAAR A,1),CAR TT),CAR SS),
		P!+(P!*(ZCONS CONS(CAAR A,1),CDR TT),CDR SS))
	END
    ELSE
	BEGIN SCALAR QQ,BB,CC,TT;
        IF NOT(POLVAR A EQ POLVAR B) OR POLEXPT A < POLEXPT B THEN
	    RETURN CONS(0,A);		% Not same var/MLG, degree check/DFM
	
	QQ:=PDIVIDE(POLCOEF A,POLCOEF B);	% Look for leading term;
	IF NOT(CDR QQ=0) THEN RETURN CONS(0,A);
	QQ:=CAR QQ;			%Get the quotient;
	BB:=P!*(B,QQ);
	IF CDAAR A > CDAAR B THEN
	    << TT:=ZCONS CONS(CONS(CAAAR A,CDAAR A-CDAAR B),1);
	    BB:=P!*(BB,TT);
	    QQ:=P!*(QQ,TT)
	    >>;
	CC:=P!-(A,BB);			%Take it off;
        BB:=PDIVIDE(CC,B);
	RETURN CONS(P!+(QQ,CAR BB),CDR BB)
        END;

SYMBOLIC PROCEDURE P!-(A,B);		%. POL subtract
    P!+(A,P!.NEG B);

SYMBOLIC PROCEDURE P!.NEG(A);		%. POL Negate
  IF NUMBERP A THEN -A
     ELSE CONS(CONS(CAAR A,P!.NEG CDAR A),P!.NEG CDR A);

SYMBOLIC PROCEDURE PDIFF(A,X);		%. POL derivative (to variable)
    IF NUMBERP A THEN 0
     ELSE BEGIN SCALAR ORD;
	ORD:=PORDERP(POLVAR A,X);
	RETURN
	IF ORD=-1 THEN 0
	 ELSE IF ORD=0 THEN 
	    IF CDAAR A=1 THEN
		CDAR A
	     ELSE P!+(ZCONS CONS(CONS(X,CDAAR A-1),P!*(CDAAR A,CDAR A)),
		     PDIFF(CDR A,X))
	 ELSE P!+(P!*(ZCONS CONS(CAAR A,1),PDIFF(CDAR A,X)),PDIFF(CDR A,X))
END;

SYMBOLIC PROCEDURE MKKERNEL X;
 BEGIN SCALAR KERNELS,K,OP;
       K:=KERNELS:=GET(OP:=CAR X,'KERNELS);
 L:    IF NULL K THEN RETURN<<PUT(OP,'KERNELS,X.KERNELS);X>>;
       IF X=CAR K THEN RETURN CAR K;
	K:=CDR K;
	GOTO L
  END;

%***************************** Parser *********************************

% Simple parser creates expressions to be evaluated by the
% rational polynomial routines.
% J.  Marti, August 1980. 
% Modified and Extended by GRISS and GALWAY
% Rewritten to be left associative by OTTENHEIMER, March 1981


GLOBAL '(TOK!*);

SYMBOLIC PROCEDURE RPARSE();	%. PARSE Infix to Prefix
BEGIN SCALAR X;
  NTOKEN();
  IF TOK!* EQ '!; THEN RETURN NIL;	% Fix for null exp RBO 9 Feb 81
  IF NULL(X := REXP()) THEN RETURN ERROR(105, '(Unparsable Expression));
  IF TOK!* NEQ '!; THEN RETURN ERROR(106, '(Missing !; at end of expression));
  RETURN X
END RPARSE;

SYMBOLIC PROCEDURE REXP();	 %. Parse an EXP and rename OP
BEGIN SCALAR LEFT, RIGHT,OP;
  IF NOT (LEFT := RTERM()) THEN RETURN NIL;
  WHILE (OP := GET(TOK!*,'REXP)) DO
    << NTOKEN();
       IF NOT(RIGHT := RTERM()) THEN RETURN ERROR(100, '(Missing Term in Exp));
       LEFT := LIST(OP, LEFT, RIGHT)
    >>;
  RETURN LEFT
END REXP;

SYMBOLIC PROCEDURE RTERM();	%. PARSE a TERM
BEGIN SCALAR LEFT, RIGHT, OP;
  IF NOT (LEFT := RPRIMARY()) THEN RETURN NIL;
  WHILE (OP := GET(TOK!*,'RTERM)) DO
    << NTOKEN();
       IF NOT (RIGHT := RPRIMARY()) THEN
	  RETURN ERROR (101, '(Missing Primary in Term));
       LEFT := LIST(OP, LEFT, RIGHT)
    >>;
  RETURN LEFT
END RTERM;

SYMBOLIC PROCEDURE RPRIMARY();	%. RPRIMARY, allows "^" and "'"
BEGIN SCALAR LEFT, RIGHT, OP;
  IF TOK!* EQ '!+ THEN RETURN <<NTOKEN(); RPRIMARY0()>>;
  IF TOK!* EQ '!- 
      THEN RETURN << NTOKEN();
		     IF (LEFT := RPRIMARY0()) THEN LIST('MINUS, LEFT) 
                     ELSE RETURN ERROR(200,'(Missing Primary0 after MINUS))
		  >>;

  IF NOT (LEFT := RPRIMARY0()) THEN RETURN NIL;
  WHILE (OP := GET(TOK!*,'RPRIMARY)) DO
    << NTOKEN();
       IF NOT (RIGHT := RPRIMARY0()) THEN 
		RETURN ERROR(200, '(Missing Primary0 in Primary));
       LEFT := LIST(OP, LEFT, RIGHT) 
    >>;
  RETURN LEFT;
END RPRIMARY;

SYMBOLIC PROCEDURE RPRIMARY0();		%. Variables, etc
BEGIN SCALAR EXP, ARGS;
  IF TOK!* EQ '!( THEN
    << NTOKEN();
       IF NOT (EXP := REXP()) THEN RETURN ERROR(102, '(Missing Expression));
       IF TOK!* NEQ '!) THEN RETURN ERROR(103, '(Missing Right Parenthesis));
       NTOKEN();
       RETURN EXP
    >>;

    IF NUMBERP(EXP := TOK!*) 
      THEN RETURN <<NTOKEN(); EXP>>;

    IF NOT IDP EXP THEN  RETURN NIL;
    NTOKEN();
    IF ARGS := RARGS(EXP) THEN RETURN ARGS;
    RETURN EXP;
END RPRIMARY0;

SYMBOLIC PROCEDURE RARGS(X);
  BEGIN SCALAR ARGS,ARG;
	IF TOK!* NEQ '!( THEN RETURN NIL;
	NTOKEN();
	IF TOK!* EQ '!) THEN RETURN <<NTOKEN();X . NIL>>;
  L:	IF NOT (ARG :=REXP()) THEN ERROR(104,'(Not expression in ARGLST));
	ARGS := ARG . ARGS;
	IF TOK!* EQ '!, THEN <<NTOKEN(); GOTO L>>;
	IF TOK!* EQ '!) THEN RETURN <<NTOKEN();X . REVERSE ARGS>>;
        ERROR(105,'(Missing !) or !, in ARGLST));
  END;

SYMBOLIC PROCEDURE MKATOM X;
%  Use LIST('RCREATE, LIST('QUOTE,x)); if doing EVAL mode
 X;

%******************* Printing Routines ********************************

SYMBOLIC PROCEDURE PPRINT A;
% Print internal canonical form in Infix notation.
    IF NUMBERP A THEN PRIN2 A  ELSE
BEGIN
	IF NUMBERP CDAR A THEN
	  IF CDAR A = 0 THEN
	    << PRIN2 '0; RETURN NIL >>
	   ELSE IF CDAR A NEQ 1 THEN 
	    << PRIN2 CDAR A; PRIN2 '!* >>
	   ELSE
	 ELSE IF RPREC!* CDAR A THEN << PPRINT CDAR A; PRIN2 '!* >> 
	   ELSE <<PRIN2 '!(; PPRINT CDAR A; PRIN2 '!)!* >>;
	IF CDAAR A = 0 THEN PRIN2 1
	   ELSE IF CDAAR A = 1 THEN PRIN2 CAAAR A
	   ELSE << PRIN2 CAAAR A; PRIN2 '!^;
		  IF RPREC!^ CDAAR A THEN PPRINT CDAAR A
		    ELSE <<PRIN2 '!(; PPRINT CAAAR A; PRIN2 '!) >> >>;
	IF NUMBERP CDR A THEN
	  IF CDR A> 0 THEN <<PRIN2 '!+ ; PRIN2 CDR A; RETURN NIL>>
	   ELSE IF CDR A < 0 THEN <<PRIN2 '!-! ; PRIN2 (-CDR A);
                                        RETURN NIL>>
           ELSE RETURN NIL;
	IF ATOM CDR A THEN <<PRIN2  '!+ ; PRIN2 CDR A; RETURN NIL>>;
	PRIN2 '!+ ; PPRINT CDR A;
END;

SYMBOLIC PROCEDURE RPREC!* X;	%. T if there is no significant addition in X.
  ATOM X OR (NUMBERP POLRED X AND POLRED X = 0);

SYMBOLIC PROCEDURE RPREC!^ X;	%. T if there is not significant addition or multiplication in X.
RPREC!* X AND (ATOM X OR
  (ATOM CDAR X AND NUMBERP CDAR X));

SYMBOLIC PROCEDURE SIMPLE X;	%. POL that doest need ()
 ATOM X OR ((POLRED X=0) AND (POLEXPT X=1) AND (POLCOEF X =1));

SYMBOLIC PROCEDURE RATPRINT A;	%. Print a RAT
BEGIN
        IF CDR A = 1 THEN PPRINT CAR A
         ELSE <<NPRINT CAR A;
		PRIN2 '!/; 
	        NPRINT CDR A>>;
	TERPRI()
END;

SYMBOLIC PROCEDURE NPRINT A; 	%. Add parens, if needed
 IF NOT SIMPLE A THEN <<PRIN2 '!( ; PPRINT A; PRIN2 '!) >>
  ELSE PPRINT A;

%. Convert RCAN back to PREFIX form

SYMBOLIC PROCEDURE RAT2PRE X;           %. RATIONAL to Prefix
 IF RATDEN X = 1 THEN POL2PRE RATNUM X
  ELSE LIST('QUOTIENT,POL2PRE RATNUM X, POL2PRE RATDEN X);

SYMBOLIC PROCEDURE POL2PRE X;		%. Polynomial to Prefix
BEGIN SCALAR TT,RR;
 IF NOT PAIRP X THEN RETURN X;
  TT:=TRM2PRE POLTRM X;
  RR:=POL2PRE POLRED X;
  IF RR = 0 THEN RETURN TT;
  IF NUMBERP RR AND RR <0 THEN RETURN LIST('DIFFERENCE,TT,-RR);
  RETURN  LIST('PLUS2,TT,RR);
END;

SYMBOLIC PROCEDURE TRM2PRE X;		%. Term to Prefix
 IF TRMCOEF X = 1 THEN PWR2PRE TRMPWR X
  ELSE IF TRMCOEF X = (-1) THEN LIST('MINUS,PWR2PRE TRMPWR X)
  ELSE LIST('TIMES2,POL2PRE TRMCOEF X,PWR2PRE TRMPWR X);

SYMBOLIC PROCEDURE PWR2PRE X;		%. Power to Prefix
 IF PWREXPT X = 1 THEN PWRVAR X
  ELSE LIST('EXPT,PWRVAR X,PWREXPT X);

%. prefix Pretty print

SYMBOLIC PROCEDURE PREPRIN(A,PARENS);	%. Print PREFIX form in Infix notation.
 BEGIN SCALAR PRINOP;
	IF ATOM A THEN RETURN PRIN2 A;
        IF (PRINOP:=GET(CAR A,'PRINOP)) 
	 THEN RETURN XAPPLY(PRINOP,LIST(A,PARENS));
	PRIN2(CAR A); PRINARGS CDR A;
	RETURN A;
 END;

SYMBOLIC PROCEDURE PRINARGS A;	%. Print ArgLIST
 IF NOT PAIRP A THEN PRIN2 '!(!)
  ELSE <<PRIN2 '!(; WHILE PAIRP A DO
		    <<PREPRIN(CAR A,NIL); 
		      IF PAIRP (A:=CDR A) THEN PRIN2 '!,>>;
	PRIN2 '!)>>;

SYMBOLIC PROCEDURE PREPRINT A;
 <<PREPRIN(A,NIL); TERPRI(); A>>;

SYMBOLIC PROCEDURE NARYPRIN(OP,ARGS,PARENS);
  IF NOT PAIRP ARGS THEN NIL
   ELSE IF NOT PAIRP CDR ARGS THEN PREPRIN(CAR ARGS,PARENS)
   ELSE <<IF PARENS THEN PRIN2 '!(; 
	  WHILE PAIRP ARGS DO
		  <<PREPRIN(CAR ARGS,T); % Need precedence here
		    IF PAIRP(ARGS:=CDR ARGS) THEN PRIN2 OP>>;
          IF PARENS THEN PRIN2 '!)>>;
	
         
SYMBOLIC PROCEDURE PLUSPRIN(A,PARENS);
  NARYPRIN('! !+! ,CDR A,PARENS);

SYMBOLIC PROCEDURE DIFFERENCEPRIN(A,PARENS);
  NARYPRIN('! !-! ,CDR A,PARENS);

SYMBOLIC PROCEDURE TIMESPRIN(A,PARENS);
  NARYPRIN('!*,CDR A,PARENS);

SYMBOLIC PROCEDURE QUOTPRIN(A,PARENS);
   NARYPRIN('!/,CDR A,PARENS);

SYMBOLIC PROCEDURE EXPPRIN(A,PARENS);
  NARYPRIN('!^,CDR A,PARENS);

ON RAISE;
END;

Added perq-pascal-lisp-project/test.sl version [3291c80a73].









>
>
>
>
1
2
3
4
1
2
(PRINT '(AHA OHO))
(RDS NIL)

Added perq-pascal-lisp-project/tpas0.pas version [7ab967767e].

























































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
(* include following two lines for terak *)
(*  [$s+] *) (* swapping mode to manage this large file *)
(*  [$g+] *) (* goto is legal *)

PROGRAM pas0(symin*,input*,output);

    (************************************************************)
    (* 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.       *)
    (************************************************************)

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

    eos = nul;      (* terminator character for strings. *)
    (* note: use chr(eos) on terak *)
    inchns = 2;       (* number of input channels.  *)
    outchns = 1;      (* number of output channels. *)

    xtoktype  =  129; (* slot in idspace for toktype. *)
    chartype  =  3;   (* various token types *)
    inttype  =  1;
    idtype  =  2;

    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.                                       *)

    (* 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.  *)
    bigtag = 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 = 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 = 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 = ascii; *)
    onechar = char;     (* for terak *)

    (* 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 = integer;
    itemtype = 0..7;    (* the tags *)


    pair = PACKED RECORD
		      prcar: itemref;
		      prcdr: itemref;
		      markflg: boolean;        (* for garbage collection   *)
		  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;    (* use long int on terak *)

VAR
    (* global information *)
    nilref,trueref: itemref;    (* refers to identifiers "nil", and "t". *)

    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;
    freeint: 1..maxintsp;

    (* 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 tag_of(item: itemref): itemtype;
    BEGIN (* tag_of *)
    tag_of := item DIV shift_const;
    END;
    (* tag_of *)

FUNCTION info_of(item: itemref): 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 *)

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 mkbigint;
	BEGIN (* mkbigint *)
	IF freeint <= maxintsp THEN     (* convert to bignum *)
	    BEGIN
	    tag := bigtag;
	    intspace[freeint] := info;
	    info := freeint;        (* since we want the pointer *)
	    freeint := freeint + 1;
	    END
	ELSE writeln('*****BIGNUM SPACE EXHAUSTED')     (* should do gc *)
	END;
	(* mkbigint *)


    BEGIN (* mkitem *)
    IF tag = inttag THEN
	IF (info < -int_offset) OR (info > int_offset - 1) THEN mkbigint
	ELSE info := info + int_offset    (* info was in range so add offset *)

    ELSE IF tag = bigtag THEN mkbigint

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

    (* pack tag and info into 16-bit item.   *)
    item := tag * shift_const + 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 bignum). *)
    (* 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) = bigtag THEN
	     number := intspace[info_of(item)]
	 ELSE writeln('***** ILLEGAL DATA TYPE FOR NUMERIC OPERATION')
    END;
    (* int_val *)


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

PROCEDURE xsetuniq;     (* just here temporarily until i can *)
    BEGIN (* xsetuniq *)(* figure out how to get them out of *)
    END;
    (* execute.                          *)
    (* xsetuniq *)

PROCEDURE xgetuniq;
    BEGIN (* xgetuniq *)
    END;
    (* xgetuniq *)


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;


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

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

FUNCTION atom(item : itemref): itemref;
    BEGIN       (* atom *)
    IF tag_of(item) <> pairtag THEN atom := trueref
    ELSE atom := nilref
    END (* atom *);

FUNCTION codep(item: itemref): itemref;
    BEGIN       (* codep *)
    IF (tag_of(item) = codetag) AND (info_of(item) <> undefined) THEN
	codep := trueref
    ELSE codep := nilref
    END (* codep *);

FUNCTION idp(item: itemref): itemref;
    BEGIN       (* idp *)
    IF tag_of(item) = idtag THEN idp := trueref
    ELSE idp := nilref
    END (* idp *);

FUNCTION pairp(item: itemref): itemref;
    BEGIN (* pairp *)
    IF tag_of(item) = pairtag THEN pairp := trueref
    ELSE pairp := nilref
    END (* pairp *);

FUNCTION constantp(item: itemref): itemref;
    BEGIN       (* constantp *)
    IF NOT((pairp(item) = trueref) OR (idp(item) = trueref)) THEN
	constantp := trueref
    ELSE constantp := nilref
    END (* constantp *);

FUNCTION eq(u, v: itemref): itemref;
    BEGIN       (* eq *)
    IF u = v THEN eq := trueref
    ELSE eq := nilref
    END (* eq *);

FUNCTION eqn(u, v: itemref): itemref;
    VAR i, j: longint;

    BEGIN       (* eqn *)
    int_val(u, i);
    int_val(v, j);
    IF i = j THEN eqn := trueref
    ELSE eqn := nilref
    END (* eqn *);

FUNCTION fixp(item: itemref): itemref;
    BEGIN       (* fixp *)
    IF (tag_of(item) = inttag) OR (tag_of(item) = bigtag) THEN
	fixp := trueref
    ELSE fixp := nilref
    END (* fixp *);

FUNCTION floatp(item: itemref): itemref;
    BEGIN       (* floatp *)
    IF tag_of(item) = flotag THEN floatp := trueref
    ELSE floatp := nilref
    END (* floatp *);

FUNCTION numberp(item: itemref): itemref;
    BEGIN       (* numberp *)
    numberp := fixp(item)       (* will have to be fixed for floats *)
    END (* numberp *);


    (********************************************************)
    (*                                                      *)
    (*              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: 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('PAIRS :',pairknt);
    writeln('CONSES/PAIRS: ',consknt/pairknt);
    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;

    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 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
		    BEGIN
		    writeln('*****GARBAGE STACK OVERFLOW');
		    halt;       (* fatal error *)
		    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;
	    prspace[prloc].markflg := 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/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 := 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. *)

    pairknt := pairknt + 1;
    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;

    (* 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;

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


PROCEDURE xterpri;
    (* need to change for multiple output channels.  *)
    (* improve choice of break/nobreak.              *)
    BEGIN
    writeln(output);
    END;


PROCEDURE xwrtok;
    (* doesn't expand escaped characters in identifier names *)
    VAR
	i: integer;
    BEGIN
    IF tag_of(r[1]) = inttag THEN
	BEGIN
	IF info_of(r[1]) = 0 THEN
	    write('0')
	ELSE
	    write(info_of(r[1]): 2+trunc(log(abs(info_of(r[1])))));
	END

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

	 ELSE IF tag_of(r[1]) = flotag THEN
		  write(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] <> chr(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
			    writeln('XWRTOK GIVEN ',tag_of(r[1]), info_of(r[1]));
    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                      *)
    (*                                                      *)
    (********************************************************)

PROCEDURE xrdtok;
    VAR
	ch: 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 possible side effect.                                *)
	BEGIN
	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;

    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; *)
	    var asccode: integer; *)
	    begin 
	      asccode := ord(ch);       (* ascii character code *)
	        WHITESP := (CH = SP) OR (ASCCODE = CR) OR (ASCCODE = LF)
	 OR (asccode = ht) or (asccode = nul);         (* null?? *)
	    end; 
	(* end of terak version *)

	(* reads bignums...need to read flonums too *)
    BEGIN       (* xrdtok *)
    IF NOT eofchnl(inchnl) THEN
	REPEAT                          (* skip leading white space. *)
	    rdchnl(inchnl,ch)
	UNTIL (NOT whitesp(ch)) OR eofchnl(inchnl);
    IF eofchnl(inchnl) THEN
	mkitem(chartag, eofcode + choffset, r[1])
	(* should really return !$eof!$  *)
    ELSE
	BEGIN
	IF digit(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
		  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);
		 anint := ord(ch) - ord('0');
		 WHILE digit(ichrbuf[inchnl]) DO
		     BEGIN
		     rdchnl(inchnl,ch);
		     anint := 10 * anint + (ord(ch) - ord('0'))
		     END;
		 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] := 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 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 *)

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

PROCEDURE xread;
    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: 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
	    prspace[i].markflg := false;        (* redundant? *)
	    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);
	    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] := chr(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] := chr(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 *)
	gccount := 0;
	consknt := 0;
	pairknt := 0;
	END;
	(* init1 *)

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

	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');

	inchnl := 2;        (* select standard input. *)
	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;

    (* apply(fn,arglist)-- "fn" is an operation code. *)
PROCEDURE xapply;
    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;

    (*  rest of pas1...pasn follow *)

Added perq-pascal-lisp-project/user.sli version [6bed3928d8].





















>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
% user LISP init for PASLSP

(PRINT  "User Init Start")
(DN LIST (AA) AA)
(SETQ INITFORM!* '(RDEVPR))
(DF ON (X) (SET (CAR X) T))
(DF OFF (X) (SET (CAR X) NIL))
(ON !*RAISE)
(OFF !*ECHO)
(PRINT  "User Init End")

Added perq-pascal-lisp-project/wicat-paslsp.aux version [c2f3c25903].

















>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
@Comment{AUXFILE of WICAT-PASLSP.MSS.1 by Scribe 3C(1250) on 1 March 1982 at 15:57}
@AuxCitation{BENSON81$=(1;;)}
@AuxCitation{BRANDT81$=(2;;)}
@AuxCitation{GRISS79$=(3;;)}
@AuxCitation{GRISS81$=(4;;)}
@AuxCitation{GRISS81E$=(5;;)}
@AuxCitation{HEARN73$=(6;;)}
@AuxCitation{MARTI79$=(7;;)}

Added perq-pascal-lisp-project/wicat-paslsp.err version [d134284fba].











>
>
>
>
>
1
2
3
4
5
@Comment{ErrLog of WICAT-PASLSP.MSS.1 by Scribe 3C(1250) on 1 March 1982 at 15:57}

Error found while finishing up after the end of the manuscript:
Cross references to 7 labels could be wrong.
Run the file through Scribe again if you need to be sure they are right.

Added perq-pascal-lisp-project/wicat-paslsp.lpt version [125b5cc6b7].

















































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
Utah Symbolic Computation Group                     December 1981
Operating Note 60










         A PASCAL Based Standard LISP for the Wicat 100
         A PASCAL Based Standard LISP for the Wicat 100
         A PASCAL Based Standard LISP for the Wicat 100


                               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: 1 March 1982






                            ABSTRACT
                            ABSTRACT
                            ABSTRACT


This  report describes an interim implementation of Standard LISP
for the Wicat 100. 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 Wicat 100 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.
Wicat Pascal LISP         1 March 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 Wicat 100
implementation. This report is to be read in conjunction with the
Standard LISP report [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 [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.


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 [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 [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
Wicat Pascal LISP         1 March 1982                          2


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, Apollo and a Wicat, 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
Wicat Pascal LISP         1 March 1982                          3


      files.
   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 Wicat, 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 Wicat 100
3. Using PASLSP on the Wicat 100
3. Using PASLSP on the Wicat 100

  Initializing the system from the floppy looks like this:


Create a directory (call it pl):
Mount the floppy:
Copy the files of interest:

    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,


(DSKIN 'Paslsp!.tst) or (DSKIN "Paslsp.tst")
Wicat Pascal LISP         1 March 1982                          4


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 Wicat 100
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 Wicat 100 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.


  Certain low level errors do not display any explanatory message
Wicat Pascal LISP         1 March 1982                          5


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 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 Wicat 100 (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) [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.
Wicat Pascal LISP         1 March 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;
Wicat Pascal LISP         1 March 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 integer, 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
Wicat Pascal LISP         1 March 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 [hearn73] 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, Wicat 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.
Wicat Pascal LISP         1 March 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 [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.



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.
Wicat Pascal LISP         1 March 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
Wicat Pascal LISP         1 March 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
Wicat Pascal LISP         1 March 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
Wicat Pascal LISP         1 March 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
Wicat Pascal LISP         1 March 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
Wicat Pascal LISP         1 March 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 Wicat 100                                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

Added perq-pascal-lisp-project/wicat-paslsp.mss version [a62d5c5151].





















































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
@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 Wicat 100)
@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
Wicat 100. 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 Wicat 100 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 "Wicat 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 Wicat 100 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,  Apollo and a Wicat, 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 Wicat,
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 Wicat 100)
	Initializing the system from the floppy looks like this:
@begin(verbatim)
Create a directory (call it pl):
Mount the floppy:
Copy the files of interest:

    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 Wicat 100 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 Wicat 100 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 Wicat 100 (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 integer, 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, Wicat 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)

Added perq-pascal-lisp-project/wicat-paslsp.otl version [f9df769f6f].







































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
@Comment{OUTLINE of WICAT-PASLSP.MSS.1 by Scribe 3C(1250) on 1 March 1982 at 15:57}
1. Introduction                                           1 WICAT-PASLSP.MSS.1 line 54
  1.1. History of PASLSP                                  1 WICAT-PASLSP.MSS.1 line 82
  1.2. Acknowledgement                                    2 WICAT-PASLSP.MSS.1 line 114
2. Features of PASLSP and relation to Standard LISP       2 WICAT-PASLSP.MSS.1 line 119
3. Using PASLSP on the Wicat 100                          3 WICAT-PASLSP.MSS.1 line 165
4. Implementation of PASLSP                               5 WICAT-PASLSP.MSS.1 line 244
  4.1. Building PASLSP                                    5 WICAT-PASLSP.MSS.1 line 245
  4.2. Internal data structures                           6 WICAT-PASLSP.MSS.1 line 287
  4.3. Adding user functions to the kernel                7 WICAT-PASLSP.MSS.1 line 320
5. Future work on PASLSP                                  8 WICAT-PASLSP.MSS.1 line 364
  5.1. Goals of the Utah PSL Project                      8 WICAT-PASLSP.MSS.1 line 376
6. References                                             9 WICAT-PASLSP.MSS.1 line 437
APPENDIX A:  A List of Current PASLSP Functions and Glo  10 WICAT-PASLSP.MSS.1 line 439
 Table of Contents                                        1 -SCRIBE-SCRATCH-.13-27-1.100013 line 3
	Alphabetic Listing of Cross-Reference Tags and Labels

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

Added perq-pascal-lisp-project/wicat-problems.txt version [94ead12563].









>
>
>
>
1
2
3
4
what is the relationship between 'a string', "a string" and arrays?

buildup of old files          

Added psl-1983/20-comp/dec20-asm.b version [1691fba461].

cannot compute difference between binary files

Added psl-1983/20-comp/dec20-asm.build version [647128045f].





















>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
CompileTime <<
load If!-System;
load SysLisp;
off UserMode;
>>;
CompileTime if_system(PDP10, NIL, <<
in "DEC20-DATA-MACHINE.RED"$
in "PC:DATA-MACHINE.RED"$
>>)$
in "DEC20-ASM.RED"$

Added psl-1983/20-comp/dec20-asm.ctl version [6283c939cc].





















>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
; Rebuild the ASM module
@term page 0
@get psl:rlisp
@st
*loaddirectories!*:='("pl:");
*load build;
*build "DEC20-ASM";
*quit;
@reset .
@term page 24

Added psl-1983/20-comp/dec20-asm.log version [9f1a8a4b68].

cannot compute difference between binary files

Added psl-1983/20-comp/dec20-asm.red version [1de9ae2065].













































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214

% 20-ASM.RED - Dec-20 specific information for LAP-TO-ASM
% 
% Author:      Eric Benson
%	       Symbolic Computation Group
%              Computer Science Dept.
%              University of Utah
% Date:        5 January 1982
% Copyright (c) 1982 University of Utah
%

%  <PSL.20-COMP>20-ASM.RED.1, 25-Feb-82 16:46:44, Edit by BENSON
%  Converted from VAX version

fluid '(CodeFileNameFormat!*
	DataFileNameFormat!*
	InputSymFile!*
	OutputSymFile!*
	CommentFormat!*
	LabelFormat!*
	ExternalDeclarationFormat!*
	ExportedDeclarationFormat!*
	FullWordFormat!*
	DoubleFloatFormat!*
	ReserveZeroBlockFormat!*
	ReserveDataBlockFormat!*
	DefinedFunctionCellFormat!*
	UndefinedFunctionCellInstructions!*
	MainEntryPointName!*
	!*MainFound
	CodeOut!*
	DataOut!*
	!*Lower
	ASMOpenParen!*
	ASMCloseParen!*
	NumericRegisterNames!*);

CodeFileNameFormat!* := "%w.mac";
DataFileNameFormat!* := "d%w.mac";
InputSymFile!* := "20.sym";
OutputSymFile!* := "20.sym";
GlobalDataFileName!* := "global-data.red"$
MainEntryPointName!* := 'MAIN!.;
NumericRegisterNames!* := '[0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15];
CommentFormat!* := "; %p%n";
LabelFormat!* := "%w:";
ExternalDeclarationFormat!* := "	extern %w%n";
ExportedDeclarationFormat!* := "	intern %w%n";
FullWordFormat!* := "	%e%n";	% FullWord expects %e for parameter
DoubleFloatFormat!* := "	%w%n	0%n";
ReserveZeroBlockFormat!* := "%w:	block %e%n";
ReserveDataBlockFormat!* := "	block %e%n";
DefinedFunctionCellFormat!* := "	jrst %w##%n";
UndefinedFunctionCellInstructions!* :=
	       '((jsp (reg t5) (Entry UndefinedFunction)));
ASMOpenParen!* := '!<;
ASMCloseParen!* := '!>;

DefList('((LAnd !&)
	  (LOr !!)
	  (LXor !^!!)
	  (LSH !_)), 'BinaryASMOp);

put('LNot, 'UnaryASMOp, '!^!-);

DefList('((t1 6)
	  (t2 7)
	  (t3 8)
	  (t4 9)
	  (t5 10)
	  (t6 11)
	  (nil 0)
	  (st 15)), 'RegisterName);

put('MkItem, 'ASMExpressionFormat, "<%e_31>+%e");

lisp procedure CodeFileHeader();
    CodePrintF "	search monsym%n	radix 10%n";

lisp procedure DataFileHeader();
    DataPrintF "	radix 10%n";

lisp procedure CodeFileTrailer();
    CodePrintF(if !*MainFound then "	end MAIN.%n" else "	end%n");

lisp procedure DataFileTrailer();
    DataPrintF "	end%n";

lisp procedure CodeBlockHeader();
    NIL;

lisp procedure CodeBlockTrailer();
    NIL;

lisp procedure DataAlignFullWord();
    NIL;

lisp procedure PrintString S;
begin scalar N;
    N := Size S;
    PrintF "	byte(7)";
    for I := 0 step 1 until N do
    <<  PrintExpression Indx(S, I);
	Prin2 '!, >>;
    PrintExpression 0;
    TerPri();
end;

lisp procedure PrintByteList L;
    if null L then NIL else
    <<  PrintF "	byte(7)";
	while cdr L do
	<<  PrintExpression car L;
	    Prin2 '!,;
	    L := cdr L >>;
	PrintExpression car L;
	TerPri() >>;

lisp procedure PrintByte X;
<<  PrintF "	byte(7)";
    PrintExpression X;
    TerPri() >>;

lisp procedure PrintHalfWordList L;
    if null L then NIL else
    <<  PrintF "	byte(18)";
	while cdr L do
	<<  PrintExpression car L;
	    Prin2 '!,;
	    L := cdr L >>;
	PrintExpression car L;
	TerPri() >>;

lisp procedure PrintOpcode X;
    Prin2 X;

lisp procedure SpecialActionForMainEntryPoint();
    CodePrintF "	intern MAIN.%nMAIN.:";

lisp procedure ASMSymbolP X;
    Radix50SymbolP(if IDP X then ID2String X else X);

lisp procedure Radix50SymbolP X;
begin scalar N, C, I;
    N := Size X;
    if N > 5 then return NIL;
    C := Indx(X, 0);
    if not (C >= char A and C <= char Z
		or C = char !% or C = char !. or C = char !$) then return NIL;
    I := 1;
Loop:
    if I > N then return T;
    C := Indx(X, I);
    if not (C >= char A and C <= char Z
		or C >= char !0 and C <= char !9
		or C = char !% or C = char !. or C = char !$) then return NIL;
    I := I + 1;
    goto Loop;
end;

lisp procedure PrintNumericOperand X;
    if ImmediateP X then Prin2 X else PrintF("[%w]", X);

lisp procedure OperandPrintIndirect X;
<<  Prin2 '!@;
    PrintOperand cadr X >>;

put('Indirect, 'OperandPrintFunction, 'OperandPrintIndirect);

lisp procedure OperandPrintIndexed X;
<<  X := cdr X;
    PrintExpression cadr X;
    Prin2 '!(;
    PrintOperand car X;
    Prin2 '!) >>;

put('Indexed, 'OperandPrintFunction, 'OperandPrintIndexed);

macro procedure Immediate X;		% immediate does nothing on the 20
    cadr X;

lisp procedure ASMPseudoFieldPointer U;
%
% (FieldPointer Operand StartingBit Length)
%
<<  U := cdr U;
    Prin2 "point ";
    PrintExpression third U;
    Prin2 '!, ;
    PrintOperand first U;
    Prin2 '!, ;
    PrintExpression list('difference, list('plus2, second U, third U), 1) >>;

put('FieldPointer, 'ASMExpressionFunction, 'ASMPseudoFieldPointer);

procedure MCPrint(x); % Echo of MC's
 CodePrintF(";     %p%n",x);

procedure InstructionPrint(x);
 CodePrintF( ";          %p%n